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ABSTRACT 


In a major technical breakthrough, a computer model for 
Bridgman-Stockbarger crystal growth has been developed. The model 
includes melt convection, solute effects, thermal conduction in 
the ampoule, melt, and crystal, and the determination of the 
curved moving crystal-melt interface. The key to the numerical 
method is the use of a nonuniform computational mesh which moves 
with the interface, so that the interface is a mesh surface. In 
addition, implicit methods are used for advection and diffusion of 
heat, concentration, and vorticity, for interface movement, and 
for internal gravity waves. This allows large time-steps without 
loss of stability or accuracy. 

No previous model has included the time -dependent curved 
interface or the effect of concentration changes on the 
melting-point. The best prior results excluded the ampoule 
temperature, and included the concentration only as a passive 
scalar in a calculation done after the flow and temperature 
solutions had been obtained. 

Numerical results are presented for the interface shape, 
temperature distribution and concentration distribution, in 
steady-state crystal growth. Solutions are presented for two test 
cases using water, with two different salts in solution. The two 
dif fusivities differ by a factor of ten, and the concentrations 
differ by a factor of twenty. The salts depress the freezing 
point, and the equations of state and state diagrams imply that at 
equilibrium, the concentration in the solid is one tenth that in 
the liquid. As a result, the melting temperatures in the two 
cases are approximately minus twenty and minus one centigrade, 
varying with the concentration along the interfaces. For the two 
cases considered, evolution to a steady state was reasonably 
rapid . 
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CHAPTER 1 


SUMMARY 


1.1 THE BRIDGMAN- STOCKBARGER METHOD 

In the Bridgman - Stockba rge r method for crystal growth, a long 
cylindrical ampoule of melt is lowered from a relatively hot 
cylindrical furnace to a cooler cylinder, with the two cylinders 
separated by a short insulating cylinder. A crystal forms at the 
bottom of the ampoule, and grows upwards. Further details are 
given in Chapter 3. 

Crystal quality is affected by the speed of growth, by the 
curvature of the interface, and by convection and other fluid 
motions in the melt. 

Rapid crystal growth leads to poor quality even for 
single - component melts, due to dislocations. With multiple 
components, there is an increased concentration of an expelled 
component ahead of the advancing crystal interface. When the 
growth is too rapid and the temperature gradient is too small, 
there is an instability, and dendrites form at the interface. 

The curvature of the interface at any low growth rate is 
largely determined by the heat flux and temperature distribution. 
This is in turn determined by the external boundary conditions, 
the thermal conductivities of the melt, crystal, and ampoule, and 
any convective heat flux in the melt. Also, the interface is not 
an isotherm if there are significant flow-induced variations in 
the concentration. 

Convection is determined by horizontal gradients of 
temperature and concentration in the melt. Vertical variations of 
the concentration arise from the component expelled during 
crystallization, and may be gravitationally stabilizing or 
destabilizing. Convection is of course effectively eliminated in 
Spacelab operations, but is a dominant effect in many terrestrial 
applications . 
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Convection in the melt can be modified and reduced by 
rotating the ampoule. This introduces the Coriolis force and 
centrifugal buoyancy forces (Fowlis and Roberts, 1986, Roberts et 
al., 1984). Another option for electrically conducting melts is 
the use of magnetic damping. A third option to reduce convection 
in the melt, and eliminate turbulence, is the use of some kind of 
porous plug, kept ahead of the advancing crystal interface by a 
mechanical means. 


1.2 OUTLINE 

In Chapter 2 we describe the objectives of this modeling 
program, and the relationship of the present model with an earlier 
simplified model, with NASA needs and with prior and future 
experimental and theoretical work. The earlier model neglected 
convection and solute effects, but included thermal conduction in 
the crystal, melt and ampoule, and the determination of the curved 
moving crystal -melt interface. We have now upgraded the model to 
include convection and solute effects. 

Chapter 3 extends the above background description of the 
Bridgman-Stockbarger method. 

In Chapter 4, we describe the problem solved by the upgraded 
model. This chapter includes the full equations and boundary 
conditions . 


Chapter 5 describes the spatial representation, and includes 
the transformed coordinates which allow us to use central 
differences efficiently on a nonuniform staggered moving mesh. 


In Chapter 6 we describe numerical algorithms for the 
representation of three simplified problems. The purpose of 
chapter is to describe the different components of our 
representation as they apply in simpler cases. 


time 

this 

time 


Chapter 7 presents our time representations of the equations. 
We use an implicit form of a leapfrog method, in which in 
alternate stages the motion is updated and the temperature, 
concentration and interface position are updated. 


In Chapter 8, we describe the input data for the code. The 
input data page format is presented. The input is in four groups, 
defining in succession the problem parameters, the material 
properties, the method parameters, and the output control 
parameters . 
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Chapter 9 describes operation of the code. We use it 
routinely on our own microcomputer and on MSFC's VAX 
minicomputers. Operation is highly automated, using command 
procedures . 

Chapter 10 presents steady-state numerical results for two 
test cases with solute but no flow. We have demonstrated 
excellent convergence with adequate resolution in VAX computer 
runs of between 10 minutes and an hour. This is because of our 
efficient algorithms and implicit methods. 

References are listed in Chapter 11. 

Appendix A is a listing of the code. 
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CHAPTER 2 


OBJECTIVES 


2.1 NASA NEEDS 

The difficulty and expense of laboratory and Spacelab 
investigations, and the problems associated with diagnostic 
observations and measurements for certain Bridgman- Stockbarger 
systems, necessitate parallel modeling efforts. Analytic studies 
have been helpful, but are of limited scope. 

Existing computer models are not adequate. Separately, they 
explain certain features of the method and of the experimental 
results, but they lack the generality required for a quantitative 
understanding of present and planned future crystal growth 
experiments. Further, the numerical methods of the more 
sophisticated models require excessive computer storage and time 
even for cases with limited resolution, no ampoule, and no 
concentration effects on the density or the interface temperature. 

A good example is the work of Chang and Brown (1983a, b,c), 
who use a f ini te - element method which determines only steady 
states. The spatial resolution is limited because of the use of 
Newton's iteration, requiring the inversion of a large full matrix 
at every iteration. Doss et al. (1984) discuss the use of finite 
elements for this type of problem. Miller (1986) reports a study 
of vapor transport in a cylinder. He includes convection, but has 
no ampoule conduction or curved interface. 


2.2 PREVIOUS PROGRAM 

Under a previous contract, we developed a 
B r idgman - S tockba r ge r code which computes steady-state conditions 
for the crystal-melt interface and the temperature distribution in 
the melt, crystal, and ampoule (Roberts, 1984). 
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The previous program had three basic objectives. The 
numerical results demonstrate that these objectives were achieved. 

First, the model provides a valid description for cases where 
solute effects and convection can be neglected. In particular, 
this applies to zero-gravity experiments with a single component 
or with a very small solute concentrations. 

Secondly, the previous program was a natural first step 
towards the long-term objective of developing a complete model. 
Many of the model components were incorporated in the present 
code, including the non - orthogonal mesh transformation, and the 
input and output routines. 

Thirdly, the previous model can be used as a diagnostic tool 
for interpreting and understanding the results of a full 
simulation. This is a significant benefit, since the time-step 
limit for a full dynamical computation is likely to be shorter 
than for the previous code. 


2.3 LONG-TERM OBJECTIVES 

Our first objective is to build a complete model, with the 
flexibility to describe a full range of Bridgman configurations 
and materials. This model would involve a simultaneous 
calculation of the coupled evolution in time of the interface, the 
flow and solute concentration in the melt, and the temperature 
distribution in the melt, crystal and ampoule. This objective has 
largely been achieved, although there are of course a number of 
code improvements and extensions required. 

Our next long-term objective is to apply the code to a wide 
range of experimental conditions, with different geometries and 
thermal boundary conditions, different materials, and with and 
without gravity. This would allow us to validate the code against 
experimental measurements and to extend the usefulness of those 
experiments. It would also suggest further experiments, both in 
the laboratory and in space. 

Our third objective is to apply the code usefully in the 
improvement of manufacturing processes. Once a code like this has 
been developed and validated, it can be applied operationally to a 
wide range of conditions as a part of process optimization. 

Further details are given in the viewgraphs on the following 
pages, and in the rest of the report. 
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A DESIGN OF SPACELAB AND SPACE STATION EXPERIMENTS 

• MODEL PROPOSED CONFIGURATIONS 

• DISCOVER POTENTIAL PROBLEMS 

• DEMONSTRATE PROBABILITY OF SUCCESS 

• DEMONSTRATE POTENTIAL FOR COMMERCIALIZATION 
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• PROPOSED SOLUTIONS 

• THERMAL BOUNDARY CONDITIONS TO CONTROL CURVATURE 

• ZERO GRAUITY ELIMINATES C0NUECTI0N 

• ROTATION REDUCES CONVECTION 

• MAGNETIC FIELD REDUCES C0NUECTI0N 
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CHAPTER 3 


BACKGROUND 


3.1 PHYSICAL PROCESSES 

In the Bridgman- Stockbarger method for crystal growth from 
the melt, a cylindrical ampoule containing the well-mixed liquid 
is lowered steadily down a matched cylindrical opening. It passes 
in succession through a hotter isothermal region (above the 
melting point), through an adiabatic ' zone, and into a cooler 
isothermal region. Crystallization begins at the bottom of the 
ampoule, and proceeds upwards as the ampoule descends. For 
crystals with high melting points, both the isothermal regions are 
furnaces, separated by a thin insulating slab, and the ampoule is 
lowered in heat pipes with matching diameter; heat exchange is by 
conduction and radiation across the air gap. 

For definiteness we will describe the mercury cadmium 
tellur ide (Cd K Hg,_ x Te) system, with the small x phase diagram 
shown in Figure 3.1. 

T 


x 


Figure 3.1 Simplified Phase Diagram 

The liquid and solid are in equilibrium at the indicated 
temperature and molar fraction x. For this system, the liquid 
density decreases with molar fraction x, and for small fixed x it 
decreases with temperature only above a temperature of maximum 
density. For larger x, the density always decreases with 
increasing temperature. 
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Large-scale longitudinal crystal inhomogeneities arise from 
the phase diagram and from melt diffusion, and are well 
understood. Figure 3.2 shows the variation of the transverse 
average of x along the final crystal, and the variation in the 
melt at an intermediate stage. The initial molar fraction of the 
melt is x Q . The bottom of the crystal is cadmium rich, and a 
cadmium deficiency diffuses ahead of the interface, and finally 
solidifies at the top. 


z 



Melt at intermediate 

stage 


Final solid 


Figure 3.2 Longitudinal Variations in the Horizontally Averaged 
Molar Fraction 

Other crystal inhomogeneities apparently arise from three 
main sources. 

1. Unsteady movement of the interface causes remelting and 
microlayers in the crystal. This unsteady movement is 
produced by temperature fluctuations associated with 
turbulent convection in the melt. 

2. Convection near the interface, due to radial 

temperature gradients, results in radial segregation of 
the molar fraction. 

3. The interface is curved, due to the same radial 

temperature gradients, and radial diffusion of molar 
fraction results in radial segregation. 
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Many methods have been suggested for alleviating these problems and 
producing better quality crystals. 

1. The first two effects involve gravity, and are 
effectively eliminated in the microgravity of space. 

2. Alternatively, the convection can be reduced and the 
turbulence eliminated by 

o Rotation, using the Coriolis force; 

o Magnetic damping, requiring an electrically 
conducting melt and an external magnetic field; 
or 

o A plug of porous material which is somehow kept 
ahead of the interface. 

3. The turbulence in the first effect mainly involves the 
radial temperature gradients near the upper isothermal 
region. Radial temperature gradients at the upper 
furnace can be reduced by insulating the sides and 
letting the heat come in from the top; which would be a 
substantial modification from the conventional design. 

4. The radial temperature gradients near the interface are 
inevitable; they are associated with the finite 
conductivity of the ampoule and the differing 
conductivities of the melt and crystal. The effect can 
be minimized by choices of the isothermal region 
temperatures relative to the melting point, and by 
careful control of the temperature on the ampoule 
boundary . 


Even if inhomogeneities in the crystal are minimized, crystal 
dislocations can be a problem. For most materials, they tend to form 
at the ampoule, and to propagate normal to the interface as the 
crystal grows. They can therefore be minimized by ensuring that the 
growing crystal has a convex interface with the melt. 


3.2 PREVIOUS MODELS 

Axial segregation is readily modeled analytically, assuming 
uniformity in the transverse directions, and neglecting convection. 
The resulting ordinary differential equation predicts the profile 
shown in Figure 3.2, in agreement with measurements. 

Analytic models have been developed for interface stability. 
These models confirm the observation that when freezing is too rapid, 
and the temperature gradient is too small, the molar fraction cannot 
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diffuse sufficiently fast ahead of the interface. When 
dT/dx = (dT/dz) / (dx/dz) 

is smaller than the upper slope in Figure 3.1, the interface can 
become unstable, and dendrites form. 

Analytic and numerical models have been developed for the thermal 
conduction problem and the interface shape, in the absence of 
convection. These models either include ampoule conduction or 
parameterize it. Many use the i sothe rmal -adiabatic - i sothe rmal furnace 
structure which we have described. 

Apparently no modelers have yet developed a full model, with 
ampoule conduction, concentration variations, an unknown curved 
interface determined by the equation of state and not necessarily an 
isotherm, and with the density a general function of concentration and 
temperature. This was our objective in the present program. 

The most advanced previous model was that of Brown and his 
co-workers. This steady-state model neglects the ampoule, and 
neglects the effect of concentration variations on the melting point 
and on the density. Thus the concentration variations are passive, 
and are computed separately once the convection flow field is known. 
In this approximation, the interface is an isotherm. Their Newton 
algorithm gives only steady- state solutions, and the computer storage 
and time requirements are respectively proportional to the square and 
cube of the number of unknown mesh point or node values. This 
severely limits the resolution which can be used, with given computer 
resources . 
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4.1 DOMAIN 

We confine attention to axisymmetric solutions. We also neglect 
transients at the ends of the ampoule. We therefore take (r,z) 
coordinates fixed to the furnace, with the ampoule and crystal moving 
down at velocity 

v = (0,-W A ) . 

Here the z-axis is upward, and W A is positive. We are interested both 
in steady and unsteady solutions, and we therefore use the full 
time - dependent equations. 

The domain is illustrated in the following figure. The heat 
equation is solved simultaneously in the crystal, melt, and ampoule. 
The flow and concentration equations are applied only in the melt. 
The crystal-melt interface is 

F ( r , z , t ) = z - f ( r , t ) = 0 , 

where the function f(r,t) is of course to be determined. The sample 
and ampoule radii r^ and r^ are input constants. The results should 
be effectively independent of the computational boundaries z^ and z T ; 
this can be tested by varying the position of these boundaries. 

The normal to the interface is in the direction of VF . The speed 
of the interface normal to itself can be written as 

- F/ VF . 

The normal velocity of the melt or crystal, relative to the interface, 
towards the melt, is 

( DF/Dt ) / I VF i . 
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z 



Figure 4.1 Computational Domain 
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Since the velocity is in general discontinuous at the boundary, the 
(DF/Dt) values are different. These results are used in obtaining 
several of the following boundary conditions. 


4.2 EQUATIONS AND BOUNDARY CONDITIONS 

The full thermodynamic and hydrodynamic equations for mixtures 
are quite complicated. Detailed discussions are given by Rosenberg 
(1979) and by Landau and Lifshitz- (I960, p. 219ff). However, for a 
very wide range of practical Bridgman-Stockbarger cases, it is 
possible to use a much simpler formulation without significant error. 
In view of the complications associated with the phase change, the 
unknown interface, and the complicated geometry, we have adopted this 
approach . 


4.2.1 Continuity 

We use the Boussinesq approximation, in which density variations 
in the melt are neglected except in the buoyancy term. This 
simplifies the treatment of the continuity equation and pressure 
gradient terms by allowing us to use a vorticity and stream- function 
formulation. No significant physics is lost. We retain a constant 
imposed density density difference between the crystal and the melt, 
as this is frequently of order 10%, and may determine a significant 
mean flow modification in the melt. 


The continuity equation in the melt becomes 


V . v = 0 . 


This allows us to write the velocity y at a point in terms of the 
stream- function \ji as 

ry = ( -\. \|i , +c) r u ) , 


where the stream- function can be interpreted physically as the volume 
flux passing upward between the axis and a circle about the axis 
passing through the point, per radian in the azimuthal direction. 


4.2.2 Equation of Motion and Vorticity Formulation 
The equation of motion is 


jO c Dv/Dt = - Vp + ^VV^v + 



4-3 



DEFINITION OF THE PROBLEM 


where p c is the constant mean density, V is the kinematic viscosity, 
and p is the density as a function of temperature and concentration. 

The vorticity equation in the conservative form 

D(W/r)/Dt = V . r -z tfV ( Mr ) + V . r~ 1 ( q/p^ )pr , 

is obtained by taking the curl of the equation of motion; this 
eliminates the pressure gradient term. We have introduced the unit 
vector r to draw attention to the conservation properties of the 
vorticity equation. The vorticity is given by the equation 

U = ^ z u - ^> r w . 

In terms of u, 

«/r = - V . r _2 ~ Vu . 


A small additional term in these equations arising from viscosity 
variations has been neglected, although we allow the viscosity to vary 
with temperature and concentration. 


The boundary conditions on the motion at the computational 
boundary at the top arc artificial. We use conditions representing 
the uniform downward flow at W A , together with a Poiseuille flow 
driven by the rate of solidification at the interface. Thus we impose 
the values of w, \ji and w, as follows. 


w = - W A + A( 1 - r Vr* ) , 
u = (A-W A )rV2 - ArV^rJ , 
w = 2Ar/r* . 


The amplitude 
solidification 

r* (A/4 


A of the Poiseuille flow is determined 
rate mass flux and the continuity condition 


• V 2) 



^ \ <V 2 


9 


by 


the 


and is 

A = (l-yo e .)[2W A + ( 4/rJ )Jf rdr ] . 

Here yO c is the ratio of the crystal density to the melt density, and 
is an input constant. 


On the axis, 


t = 0 , 
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W = 0 . 

This is just a choice of the arbitrary constant in u, together with 
the condition that the axis is not a singularity of the flow. 

On the ampoule, we impose the value of u and of its radial 
derivative. The value is determined as on the top boundary, 

u = r^(A/4 - W^/2 ) . 

The radial derivative is 



to satisfy the no-slip condition. 

The first boundary condition at the interface is the condition of 
zero slip tangential to the surface. This takes the form 

[v] x VF = 0 , 

which can be reduced to the equation 
(rW A + o r u)X r f - ^ z u = 0 . 

The second boundary condition is that the mass flux across the 
interface is continuous. If the densities are different, this implies 
a discontinuous normal flow. The boundary condition is 

[^DF/Dt] = 0 , 

which reduces to the equation 

- p c ( f + W, ) = - f + ('d u + c) f^ u)/r . 

Note that on multiplying by rdr and integrating along the 
interface, this gives a result consistent with the earlier expressions 
for A and for u on the ampoule. 


4.2.3 The Temperature Equation 

The temperature equation in the crystal, melt, and ampoule is 
C p DT/Dt = V.KVT , 

where c. p is the thermal capacity per unit volume at constant pressure. 
The thermal conductivity K naturally has separate formulations in the 
melt, crystal, and ampoule. 
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Our external thermal boundary conditions are 
T = T_ p at z = z T , 

T = T. B at z = z B , 

T = T r at r = r A ' 2 > z h ' 

T = T B at r = r A , z < z c , 

oT = 0 atr = r A , z„ < z < z .. . 

A ° rt 

We also have the option, determined by an input parameter, of 
replacing the last boundary condition by the following one, 

T = T^(z) at r = , z c < z < z H , 

where -T^ (z) is a linear interpolation between T t at z T and T B at z . B . 
Other options for the external boundary conditions could be added, to 
increase the flexibility of the code. 

The above conditions allow the option of taking z- < z H , so that 
the hot furnace is above the domain, and the upper boundary 
temperature is a calculated value. The same option is available at 
the bottom. 

The interior temperature boundary conditions are the continuity 
of temperature and heat flux, modified by the latent heat release. In 
these equations, [T] denotes the difference between the melt or 
ampoule value and the value on the crystal or sample side. They take 
the form 


[T] = 0 

at 

r = 

r s ' 

[T] = 0 

at 

z = 

f , 

[Kb._T] = 0 

at 

r = 

r s ' 

[UyODF/Dt - KVT.VF] = 0 

at 

z = 

f . 


In the last equation, U is the internal energy per unit mass. From 
the mass continuity boundary condition, the factor pDF/Dt is 
continuous. But [U] is the latent heat per unit mass. So 

L H DF./Dt - VF . [ KVT ] =0 at z = f . 

Here L H is the latent heat per unit volume of melt, a function of the 
temperature at the interface, and DF/Dt is evaluated in the melt. 
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4.2.4 The Concentratien Equation in the Melt 

Our concentration variable x is strictly the mass fraction, or 
the ratio of the mass density of one species to the total density. It 
can also be interpreted as the molar fraction, with x molecules of one 
species to (1-x) of the other. With typical magnitudes, the error is 
not significant, provided the problem parameters and material 
properties are appropriately adjusted. 

The concentration equation in the melt is 

Dx/Dt = V .c<Vx , 

where t< is the diffusivity. 

The concentration boundary conditions are 

x = x_ at z = z T , 

i * 

6 r x = 0 at r = r s , 

where x- is an imposed top inflow value. The interface boundary 
conditions arising from the equation of state are 

x = x (T) at z = f+ , 

x = x t ( T ) at z = f - . 

Here the functions x m { T ) and x t (T) are the equation of state 
functions, illustrated in Figure 3.1. The conservation of solute mass 
boundary condition is 

[x^jDF/Dt - ^OpsVx.VF] = 0 at z = f . 

In this equation, the inside of the bracket is the normal mass flux of 
the solute. Note that oc is zero in the crystal. From mass 

continuity, the term pDF/Dt is the same on each side. Thus the 
boundary condition can be rewritten as 

[ x ] DF/Dt - *Vx.VF =0 at z « f , 

where DF/Dt and «tVx are evaluated in the melt. The solute deficiency 
(or excess) resulting from the production of crystal with a larger (or 
smaller) concentration than the melt, diffuses away into the melt. 

Note that there is effectively one boundary condition too many at 
the interface. The extra boundary condition determines the interface 
position and its time evolution. 
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4.2.5 Crystal Concentration, Remelting, and Slush 

The concentration equation in the crystal, with no diffusion, is 
Dx/Dt = 0 . 

The general solution is 
x = X ( r , z+W^t ) , 

where the function X is determined by the the crystal concentration 
x^(T) at the interface, provided there is no remelting. 

If there is remelting, a single value of (r,z+W A t) will 
correspond to two connected points (r,z,t) on the interface, with in 
general distinct values of x 0 (T). Thus our system of equations is 
inconsistent for this case. 



Figure 4.2 Periodic Remelting of the Interface 


This is illustrated by the figure, which displays the interface 
position f as a function of time, for some fixed radius r. The lines 
with slope -W^ are characteristics, with constant concentration x. 
This concentration is determined by the value at the first 
intersection of the characteristic with the interface. If the 
interface moves down with a speed greater than W. , then there is 
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remelting. The interface then intersects characteristic lines on 
which the concentration x is already known, and is inconsistent with 


the 

local value 

of x 

( T ) deb 

ermined by the conditions at 

the 

inte r f ace . 


C 






This inconsist 

:ency 

arises in 

our 

system of 

equations because 

of 

our 

neglect of the 

slush 

obtained 

when 

crystal 

is melted. 



The following 

f igur 

e illustr 

a t es 

a typical 

phase diagram. 

The 


central region is excluded. Thus at the indicated fixed temperature 
the solid and liquid can exist in equilibrium at the two corresponding 
concentrations. For many binary mixtures, both curves have negative 
slopes, or one has a very steep or infinite slope, but the situation 
is still very similar. 



Figure 4.3 Typical Phase Diagram to Illustrate 
Remelting and Striations 

When melt is cooled at the indicated fixed concentration, one of 
three things can happen, as follows. 

1. A f i ne ly - di spe r sed suspension of amorphous solid 
particles or mi c ro - crystals in the melt can form 
("slush"), with the solid proportion gradually 
increasing as the temperature is lowered. The 
concentration in the resulting solid is highly 
nonuniform on a microscale. 
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2. A crystal can form at a higher concentration, with the 
corresponding concentration deficiency diffusing away 
into the melt. This, of course, is the objective in 
Br idgman - Stockba rge r crystal growth. 

3. When the growth rate is too large, the concentration 
deficit cannot diffuse away fast enough. There is then 
an instability at the advancing 'crystal interface, 
resulting in the formation of "dendrites", a forest of 
tiny crystals growing out into the melt. In practice, 
this alternative is very similar to the first. 


When a crystal is warmed at the same fixed concentration, there 
is only one possible outcome, the formation of a finely-dispersed 
suspension of amorphous particles or micro-crystals. The proportion 
of solid in this slush gradually decreases until it is all liquid. 
The concentration in the liquid will then be nonuniform, but unless 
there has been significant gravitational settling in the slush, 
diffusion should reduce or eliminate this non-uniformity in a 
relatively short time. 

If there is remelting in a model computation, the model will 
still predict the crystal concentration and its time evolution at any 
radius. The solution is correct, provided the crystal happens to have 
exactly the right concentration distribution as it advances into the 
melt. Clearly this is an unphysical requirement; the crystal 
concentration is determined by the conditions when it formed, and not 
by the conditions when it remelts. 

In Bridgman - Stockbarger crystal growth, if remelting occurs, the 
resulting crystal will be striated, and will probably contain refrozen 
slush in thin microlayers. 

Our objective in this program is to determine conditions for the 
growth of acceptable crystals, rather than to analyze in detail the 
crystal structure when there is remelting. We have not therefore 
included a parameterization of possible slush regions in our model. 
Our model therefore correctly predicts the onset of remelting, but not 
its outcome. 


4.3 MATERIAL PROPERTIES 

For many relevant materials, the properties vary significantly 
over the relevant ranges of temperature and concentration. We have 
therefore made all of our material properties general functions of 
temperature and/or concentration. They are f lexibly-def ined 
polynomials in the present formulation, with their form defined by 
input constants as described in Chapter 8. Additional options could 
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be added as required. 
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SPATIAL REPRESENTATION 


Our system of equations is a difficult one for numerical 
solution, for the following reasons. 

1. The crystal-melt interface is curved, time-dependent, 
and unknown. 

2. There are three separate coupled computational regions. 

3. The temperature and concentration equations are coupled 
by the interface conditions. 

4. The very low diffusivity for concentration, and the 
possible rapid motion driven by convection, imply thin 
boundary layers and associated computational problems. 

5. The widely different dif fusivi ties for heat and solute 
can lead to double diffusive flows. Particularly 
troublesome numerically are thin cold ascending plumes 
( " sal t - f inge r s " ) , buoyant because of the solute, and 
not stabilized by the temperature gradient because heat 
diffuses in from the sides as they rise. 

6. The large kinematic viscosities and thermal 
di f fusivities of relevant materials can restrict the 
time step for most methods. 

7. For most cases with convection, there are regions with 
strong stratification and large Vaisala (internal wave) 
frequency, further restricting the time step for most 
methods . 

8. Experimental times are frequently very long, with low 
ampoule speeds. 

Efficient numerical methods are therefore essential. 
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Our spatial representation is described in this chapter. Some of 
our choices were influenced by the requirements of the time 
representation, as described in the following chapter. 


5.1 CHANGE OF COORDINATES 

We use a uniform mesh, with unit mesh spacing, applied to the 
transformed coordinates i and k. Here r is a function of i, chosen to 
resolve the possible thin boundary layers. Similarly, z is a function 
of k and of f(r,t). This function is chosen so that k is constant on 
the interface, and varies rapidly in boundary layers on the interface 
or possibly elsewhere. Since f(r,t) is changing, the mesh is not 
fixed in terms of the r and z coordinates. 

The function f(r,t) is itself represented by its values at 
discrete times and half - odd - intege r values of i. 


5.1.1 Radial Mesh Transformation 

At compilation time, the number of i intervals allocated to the 
sample (NR) and to the ampoule ( NRA ) are specified. In the r interval 
for the sample, we take the mesh spacing dr/di as proportional to the 
function 

( r + a ) ( r +a - r) , 

where the a values are distinct input constants, estimates for the 
layer thicknesses. We use a similar expression for the ampoule r 
interval. These equations are readily integrated to give r and dr/di 
as functions of i, evaluated at the integers and at half-odd integers. 
The i values for the axis, sample boundary, and ampoule boundary are 
1, 1+NR, and 1+NR+NRA . 

Derivatives with respect to r can then be represented as 
derivatives with respect to i, using finite differences with unit mesh 
spacing. Thus for half - odd - intege r i, 

'bf = dio.f 
r r » 

= d , i [ f ( i + 1 ) - f ( i - 1 ) ]/2 , 


Note that f is defined at the half-odd integers. For integer i, 
o r f = d r i [ f ( i+1/2 ) - f ( i - 1/2 ) ] , 
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The central differencing and averaging operators 6 ^f and 
defined by the above equations, and will be used extensively. 



are 


5.1.2 Value Of f In The Ampoule 

The value of f is required in the ampoule, in order to define the 
mesh. It is a function of time alone, equal to the value on the 
sample boundary. We obtain this value by extrapolation of the three 
sample f values adjacent to the boundary. The r derivative is 
obviously zero. 

Second order formulations are used to obtain c$ r f in the sample, 
at the boundary and at the half point adjacent to the boundary. 
Clearly, it would be invalid to use a central difference formulation 
which involved the f values in the ampoule. 


5.1.3 Axial Mesh Transformation 

Our transformation uses two input parameters, z-j. and L_ . Here z^ 
is a nominal mean position for the interface position f, and the mesh 
is approximately Cartesian for distances from the interface greater 
than L j . 

We take k as increasing downwards from the top, because some 
Fortran compilers only allow lower limits of unity for arrays, and 
many of our functions are defined only in the melt. 

We first introduce a function ^ of k only, equal to z T , z x , and 
Zg , respectively, for k values of 1, 1+NZ, and 1+NZ+NZS. At 
compilation time, the number of k intervals allocated to the melt (NZ) 
and to the crystal (NZS) are specified. Our expressions for ] as a 
function of k are then analogous to the calculation of r as a function 
of i, as described above. Thus in the 3 interval for the melt, from 
z T to z-, we take the mesh spacing d3/dk as proportional to the 
function 

(3 - z 1 + a ) ( z r + a - ^ ) , 

where the a values are again distinct input constants. We use a 
similar expression for the crystal interval, from z- to z g . These 
equations are readily integrated to give "3 and d3/dk as functions of 
k, evaluated at the integers and at half - odd - intege rs . 
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We next write 

z = ^( k ) + y{ k ) { f ( r , t ) -z^.} . 

For k values in the melt (1 to 1+NZ ) , we take 

y= { ( Z r -3 )/( Z T -Z X ) }/{ l+f$ -Z x )/L I } , 

so that n is one at the interface and is zero at the top. The L x term 
makes 9 small for |}-z x | > L^. . For k values in the crystal (1+NZ to 
1+NZ+NZS), we take 

j = {(”5*Zg)/( z % - Zg ) } / { 1 + ( z ^ ) /L 

Then 

z = f for 3 = z l ' 

z = z- for X = z„ , 

I ) I 

z = z B for I = z a , 

z = 3 for I V z x' >> L X ' 

z = f + ^ - z L for |^*z 1 ! << L ^ . 

The inequalities demonstrate the purpose of L x , which is to confine 
the mesh distortion effect of f to a limited region near the 
interface . 

For bad input choices of Zj or L- , ^ k z can become unacceptably 
small as f changes. The code avoids this by appropriate adjustments 
to z_ and L T in the early stages of the computation, ensuring that Lj 
is greater than an imposed multiple of the maximum of | f - z j ! . 

Note that z, f, and k form a functionally related triad. The key 
properties of this triad are 

^z = y = {& z f ) , 

\ z = + ( f ' 2 i )d k7 = (\. k) 1 ' 

= " (d k^ + (f ' z I )< V? )/ 7 = ( \ k) 

and these properties are used in evaluating the various required 
derivatives . 


5-4 


SPATIAL REPRESENTATION 


5.1.4 Transformation of Partial Derivatives 


Care is required in the transformation of partial derivatives, 
because the z coordinate depends on both i and k. Thus from 
multivariate calculus, 

"b^T =^ r i^ t T + ''b^k^^T , 

"Vt ■'Vib.T + ^ kb. T , 

x 2 . c- z, k 

Of the four mesh derivatives, only ^ x i is identically zero. Hence, 
using the relationships derived above. 


"'b r T = d r i[b l T - y'b t T ) , 


T = "b kb, T . 

z- *• k 

The partial derivatives with respect to i and k can now be represented 
directly as central differences. 


5.2 STAGGERED COMPUTATIONAL MESH 

Functions of i and k are represented by their values at either 
whole (W) or half -odd- integer (H) values of i and k. Our choices are 
shown in the following table. 

Variable i k 

h w w 
W w w 

u W H 
w H W 
T H H 
X H H 
C ? H H 
K H H 
Tw H - 
X*\ H - 
H - 
L H H - 
p H H 
cx H H 
V H H 
f H - 

Quantities defined only at the interface are indicated with dashes in 
the k column. Note that the material properties depend on T and x, 
and are therefore most conveniently evaluated at those points. 
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and sc 


replacing the k derivative of x by the finite difference, 
Vx - rd.^rf^S^lc^ + = 0 . 


5.3.1 Concentration Flux in the i Direction 

For the cell boundaries in the i direction, the surface is 
defined by the equation 

F ( r , z , t ) = r - r ( i ) = 0 , 

and the flux can be obtained (as in our discussion of the interface 
boundary conditions in the previous chapter) as 

C. = ( rb . z ) ( xDF/Dt - . VF )/ ! VF j . 

Here the first bracket is the area of the boundary segment (per 
azimuthal radian), and the remainder is the flux per unit area 
crossing the cell boundary in the direction of VF . Simplifying this 
expression , 

C. = r\z ( xu - 

The radial derivative is represented using the above equation. The 
horizontal velocity u is represented in terms of the stream function u 
as 

r^zu = - &^u - 

The representation is therefore 

c = - x'^ii - ^ l rd r i (\zS. L x - rj S^f^x^ ) . 


5.3.2 Concentration Flux in the k Direction 

For the cell boundaries in the k direction, the surface is 
defined by the equation 

F ( r , z , t ) = z - z ( k , f ( r , t ) ) = 0 , 

and the flux can be written as 

C k = ( rd L r I VFj )( xDF/Dt - ©<Vx . VF )/ I VF | . 

Here the first bracket is the area of the boundary segment (per 
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azimuthal radian), and the remainder is the flux per unit area 
crossing the cell boundary in_the direction of VF. Expanding this 
expression, and dropping the f term which comes from the moving mesh, 

C k = rd l r[x(w - ijub r f) - *(\.x - 7?b r xb r f)] . 

The advection coefficient is 

r ( w - uyb - f ) = *b r li + 

= d ib • h . 

V L 

The diffusion bracket is 

b^kb^x - yb r fd r i('b r x - ^Vfbjtb^x) 

= N b k 3cb_k[l + (^f) 1 ] - yb c xb> r f d^i . 

The representation is therefore 

= x^c.^u - r [ & k xd ^ rb^ k { 1 + {y^> r f)' } - 77 ^x^ b^f ] . 


5.3.3 Upwind Differencing Option 

The diffusivity < is very small, and for flows of any significant 
magnitude the upwind diffusion length scale o</|yi is less than the 
mesh spacing. This can lead to odd-even mesh separation in certain 
circumstances. In this phenomenon, the concentration values at the 
odd mesh points appear to represent a different function from those at 
the even points. 

To control such problems, we use an upwind differencing option, 
implemented in the following form. We can write the above 
representation of the flux C k as 

C k = xl<G k + D k^k x + E k^i X ' k ‘ 

We then replace D , which is positive, by the largest of D and 
u x !G k |, where u* is an input parameter, the upwind differencing 
coefficient for concentration. We make the same substitution for C^, 
G: , and D. . 

*- C. 

Clearly, this change has has no effect if u x is zero or smaller 
than the minimum of D^/|G k ! and of Di/jGj. If D K is small, G is 
positive (representing upward flow), and u^ is 0.5 (the largest useful 
value) then 


C k = G k x(i ' k+1/2) • 
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This explains the name of upwind differencing, since the point 
(i,k + l/2) is upwind from the mesh point where we are evaluating C i. 

If there is any sign of odd-even mesh separation, a u x value of 
0.1 or less is generally sufficient to remove it. This applies when 
the effect is a consequence of the spatial representation only, and is 
steady in time. Numerical instability of the time representation 
sometimes produces a similar odd-even mesh separation, but it applies 
to the time dependence as well. 

The effect of upwind differencing is fairly easy to understand in 
one spatial dimension. We do not present a detailed analysis here. 

The corresponding options are available for temperature and 
vorticity, with separate input constants u T and u u . Since the 
di f fusivities are so much larger than ©<, these options will rarely be 
needed . 


5.3.4 Boundary Conditions on the Concentration 
At z T , we apply 
= x-r , 

to get the concentration half a mesh point outside the boundary. This 
is used in getting C^ on the boundary, and C. just inside the 
boundary, from the formulas above. 

With sufficiently rapid melting or freezing (according to the 
sign of the factor 1 -/o c ) , the upward velocity w may be negative at 
the top, for r values sufficiently near the axis. If this occurs, we 
apply the passive boundary condition 

o . x = 0 , 
l< 

instead of imposing the concentration. This will avoid mesh 
separation. Our mesh near the top will normally be inadequate to 
resolve upwind diffusion of concentration. 

At the axis and at r^ , we apply 

C = 0 . 

U 


In addition, we use 
<^\x = 0 , 

at the axis, to get the concentration half a mesh point outside the 
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boundary. This is used only in getting the last term of C k just 
inside the boundary, from the formula above. 

We do not use this symmetry condition to get the external x at 
the sample boundary r s , because that would be inaccurate. Instead, 
for the C ^ values just inside the sample boundary, we replace the term 
Sjx' by the one-sided difference S x H , evaluated half a mesh point to 
the left. 

The boundary conditions at the interface are discussed below. 


5.4 TEMPERATURE EQUATION AND BOUNDARY CONDITIONS 
5.4.1 Relationship with the Concentration Equation 

Our representation of the temperature equation is the same as our 
representation of the concentration equation, with the following 
exceptions . 

1. The functions x and c*. are naturally replaced by T and 
K, and V is replaced by c ? V. 

2. In the advection terms in the fluxes C; and C^ , with x 
not differentiated or differenced, x is replaced by 
cyr. 

3. The temperature equation is applied in all three 
regions, the melt, the crystal, and the ampoule. 

4. For the solid regions, the horizontal advection 

term is dropped from C^. 

5. For the solid regions, the o:\ a vertical advection term 
in C^ is replaced by - rd ^rW ft . 

6. For the top boundary, the same boundary condition is 
applied, using T_. . 

7. For the bottom boundary, the corresponding boundary 
condition is applied, using T g . 

Additional conditions are required at the interface and at t s and r^ , 
as described below. 

This representation is not strictly accurate if c-p varies 
significantly from mesh point to mesh point. The point is minor, 
since any variation does not play an important role. 
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5.4.2 Temperature Boundary Conditions on the Ampoule 

The boundary conditions can be conveniently represented by 
imposing T v as T t or T B for the hot and cold furnace sections, and 
setting £ L T to zero for the insulated segment in between. If the 
insulated segment is replaced by the imposed linear temperature 
gradient T^ ( z ) , then T' is set to T^(z). 

Because the boundary condition changes discontinuously for the 
insulating case, and in a z region where the mesh spacing is not 
necessarily very small, we have introduced an option of smoothing the 
boundary condition in the z direction. We therefore apply a weighted 
sum of the three boundary conditions, with weighting functions 

W H (z) = [1 + tanh{ ( z -z H )/s H } ]/2 , 

W c (z) = [1 - tanh{ ( z -z^)/s e } ]/2 , 

which vary smoothly from 1 in the furnaces to zero elsewhere, on 
length scales s 4 and s o equal to an imposed multiple of the local mesh 
spacings ^z at z H and z^ . The result is 

( 1 -W M -W )S l T + W H (2T k -2T r )+ W c ( 2T*'-2T ;B ) = 0 . 

If the imposed multiple is zero, this reduces to the discontinuous 
boundary condition described above. 

This relation is used to obtain T half a mesh point outside the 
boundary. This is then used in getting on the boundary. Note that 
C * just inside the boundary is not affected, since f is constant in 
the ampoule. 


5.4.3 Temperature Boundary Conditions Between the Sample and the 
Ampoule 


The objective here is to use representations of the two boundary 
conditions to obtain a representation for the common heat flux at 
the boundary. Note that in general the quantities K, d^r, and b r f are 
discontinuous at r^ . 


We have four equations in four unknowns, at each half -odd- integer 
k value. The unknowns are the required flux C^, the temperature T, 
and the two external temperatures which extrapolate smoothly from the 
sample and ampoule. The equations can be written as 

C . = D S,T + E S, T^ , 

*• s l s ,-j k - 


C. = D a £ T. 
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T 

T 




Note that E . is zero in the ampoule, because the interface slope is 
zero. This system would be straightforward except that the k 
differencing and averaging in the E s term couples the unknowns at 
different k values. So we approximate as 6 k T‘* , the value 
obtained using the known temperatures half a point from the boundary 
on the two sides. Hence 


c : 


= DS: 


T + 


E^T' 


D 


2D S D A /(D 3+ D fl ) , 


E = 


vy (D 3 + v 


For the two representations on the sample boundary and 
adjacent to the interface, we use the one-sided difference term EOj < T'', 
evaluated half a mesh interval further away from the interface. __Also, 
as with the concentration, we use the one-sided difference Ec^.T 1 ^ for 
C ^ at points next to the sample boundary. 


5.5 INTERFACE BOUNDARY CONDITIONS 

Our representation of the temperature and concentration boundary 
conditions involves additional unknowns, the temperatures Tj on the 
interface at the hal f - odd - integer i values. These determine the 
corresponding melt and crystal concentrations (from the equations of 
state x jy> (T) and x (T)) and the interface values of c^ (both sides), K 
(both sides), L , and 

There are special representations of the three interface C 
values (two for heat and one for concentration). For mel 
concentration , 

C k - + D k ' 

D = - oCr[2(x^-x k )d -rb x k{l+(o r f f } - ^"x^f } ] . 

The diffusion component D^ is referred to below. Note that we have 
replaced x K and < K by and U, and 6^x by 2(x w -x^), where x ^ is the 
value at the mesh point half a mesh interval from the interface. This 
is directly analogous to the above formulation for the interface 
between the sample and the ampoule. An external x value, extrapolated 
from the melt to half a mesh point below the interface, has been 
introduced, and then eliminated using the condition, 
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This same external x value is used and then eliminated in the x 
equation at the HH points next to the interface, in the representation 
of the f term, which includes the expression 

Next to the axis and to the sample boundary, the term is 
replaced by the one-sided differences S-ja^/2 and S L x , respectively. 
The 2 factor reflects the use of axis symmetry, as with Cj^ in the 
melt. 


The two interface C k representations for heat are obtained by 
replacing x by T , multiplying by c p for advection, and using 
2(T X -T^) and 2 ( -T^ ) for 8 k T on the two sides. The values of dzk , K 
and c-p are of course different on the two sides. The advection 
coefficient in the crystal is also modified from that in the melt, 
with <5^u replaced by -rd^rW^. 


The two additional boundary conditions are the equations for the 
conservation of material and heat, and can be regarded as determining 
the interface temperature and movement. For concentration and 
temperature respectively, they are 


[x]£{yO c rd. t r(W^+f ) } + = 0 , 

L «<rc rd i. r( v i)1 + D fc.« • v ■ 0 • 


Here D^. and are the diffusive heat flux components in the melt 
and crystal, formulated as described above. The latent heat and 
solute deficiency or excess are released at the interface, and diffuse 
away . 


Note that the melt volume flux crossing the interface, including 
the contribution from the interface movement, can be written in the 
alternative forms, 

rd *r ( DF/Dt ) = S.d - rd.rf 

= - f c rd t r(f+W^) . 


The representation at (WH) points of C t for concentration 
includes a term which can be written as Ecf^'x''^. Adjacent to the 
interface, this must be replaced by 



where x"”^ is 
Corresponding 
and below the 



evaluated at k=NZ , one point from the 
representations must be used for temperature, 
interface . 


interface . 
just above 
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In 

special 
the ave 


the ampoule, the 
treatment. In 
rage of the two 


discontinuity 
C 6 t k must be 
k z values. 


in at k=NZ+l requires 

replaced by the reciprocal of 


5.6 VORTICITY EQUATION 


the 


The vorticity is represented by its values at 
melt and on its boundary. 


the (WW) points 


in 


Our representation of the vorticity equation is analogous to that 
for the concentration equation, with a flux formulation which 
conserves representations of the volume integral of (to/r) and (under 
the action of advection alone) of its square. The representation is 

- d ■r^T C S il tt K + o L C„ + ^ K c k = 0 • 


Here the 
C „ and 
the cell 
and (WH 
buoyancy 


unit cell is centered at the vorticity mesh point (WW) , and 
C k are the fluxes of (to/ r) crossing corresponding sections of 
boundaries. The fluxes are defined respectively at the (HW) 
locations, and include advection terms, diffusion terms and 
terms . 


5.6.1 Advective Fluxes for the Vorticity Equation 

Our representations of the advection components of and C K are 
analogs of those for concentration, as described above. The mesh 


locations are 

changed . 

We take 


1 ( 

vX 

Cl = 

- (to/r) d 



k ( 


H 

U 

+ (u)/r ) c 

L 


Note that averages of u must be used in obtaining the volume flux 
across these cell boundaries. 


5.6.2 Buoyancy Term for the Vorticity Equation 

The buoyancy contribution to the fluxes and arises from our 
representation of the radial fluxes across the interface areas, as 
with concentration, and is 

— k\ 

cl = + (g /fo)p d R z * 

c k = - <9//°c • 
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5.6.3 Diffusion Term for the Vorticitv Equation 

Our representation of the diffusion term contributions to the 
fluxes of (<i/r) across the cell boundaries is again analogous to that 
used for the concentration equation. We take 

C; = - )d r i (Or ) - 1 )** J > 

C K = - (T/r ) [ <f k (Wr )d L r^ x k{ l+(^^ p f ) a } - 7^ r f£jQr )^ ] . 

5.7 STREAM -FUNCTION EQUATION 

The stream- function is represented by its values at the (WW) 
points in the melt and on its boundary. 

The definition of the vorticity in terms of the stream- function 
as a divergence allows us to use the representation 

-VW/r = 5 C. + i.Ci. , 

L L K N 

where C> and are fluxes across the boundaries of the unit cell with 
volume V, centered on the lji point. Our representations for and Cj, 
are 

C : = r~' d r i [^z^ip - a f C <^ip ^ ] , 

C^ = r _l [ (T^ud ^rV^k { 1 + (yc$ r f) 2 '} - T|^ r f£. u . 


5.8 BOUNDARY CONDITIONS ON THE MOTION 

There are two boundary conditions on the motion, on the whole of 
the melt boundary, as presented earlier. The functions ip and Q are 
represented by their values at (WW) points, which includes points on 
the four boundaries. 

The top is straightforward, as we have expressions for \Ji and (li 
there , 

u 

w 


= (A-W A )r*/2 - ArV4rJ , 
= 2Ar/r?' . 
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The axis is straightforward, since u and are zero. 

On the boundary of the melt with the ampoule, we impose the 
values of u and of o^u (both constants). Because \ti is constant, there 
is no k derivative when o r u is transformed to i,k coordinates. Thus 
our representations are 

u = rJ(A/4 - W a /2) , 

= -r s W A d L r . 

This latter boundary condition determines the value of i|i(NR+2), one 
point outside the boundary, in terms of the value one point inside. 
This allows us to evaluate H on the boundary, using the same formula 
as in the interior. 

The interface conditions must be transformed to i,k coordinates 
and represented using finite differences applied to ii. The mass 
conservation condition becomes 

<f L h = r d ^ r [ (1 yO c ) f - ^p c W A ] . 

Thus u is obtained on the interface as 

u = ( l-/O e )!>J rd^r - ^> c W A r°/2 , 

where the sum is over the half points on the interface, from the axis 
out to the whole point where p is being found. 

We can now obtain the numerical representation of A, by matching 
the above expression with u on the ampoule. The result is 

A= ( 1 -/°d. ) t 2w /\ + ( 4 / r s ) ] ' 

where the sum is over the whole interface. This expression 
corresponds exactly with the analytic expression in the previous 
chapter . 

The no-slip condition then reduces to the form 

z^f ( rW^ + d r i^u C ) / [1 + (^ r f) 2 ] . 

This determines a value for \ji(NZ+2), one point below the interface. 
This in turn allows us to evaluate on the boundary, using the 
representation presented earlier for the stream- function equation. 


5.9 SUMMARY OF THE SPATIAL REPRESENTATION 

Depending on the resolution, we have a very large set of 
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equations, determining the rate of change of the temperature, 
concentration, and vorticity, at each appropriate mesh point, and the 
position of the interface and its rate of change, at each radial mesh 
point. The rates of change for the individual temperature, 
concentration and vorticity values only enter one of the equations. 
On the other hand, practically every equation involves one or more of 
the rates of change of the interface positions. In addition, we have 
equations determining the stream function mesh-point values in terms 
of the other variables. The total number of equations is of course 
equal to the number of unknowns. 

The equations can be conveniently divided into two groups. The 
first is concerned with temperature and ^concentration, with the 
corresponding boundary conditions, and with the interface. The second 
group is concerned only with the motion in the melt. Although the 
interface position and its rate of movement enters into both groups, 
it is the first group that should be regarded as determining the 
interface. 

The T and x equations involve the neighboring T, x, and itt values, 
together with the f values at the same radial mesh point and the three 
neighboring f values. The boundary conditions on the top, bottom, and 
ampoule boundaries, and on the ampoule - sample interface, are required 
to close this system. In addition, the boundary conditions at the 
crystal-melt interface involve the interface values of T and x, the 
values half a mesh interval above and below, the local f and f values, 
and the f values at the two neighboring mesh points. 

The b) equations involve the neighboring fc), lb, and p values, 
together with the f and f values at the two neighboring radial mesh 
points. The u equations only involve the 0 value, the eight 
neighboring iji values, and the f values at the two neighboring mesh 
points. The boundary conditions do not introduce additional 
complications, except that due to the no-slip condition the boundary 
conditions cannot be used to express fc) on the boundary in terms of the 
neighboring values. Instead, the definition of U in terms of \|i must 
be used, in conjunction with the two boundary conditions on \ji . 
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CHAPTER 6 

TIME REPRESENTATIONS FOR SIMPLIFIED PROBLEMS 


The main features of our time representation, described in the 
following chapter, are as follows. 

1. Implicit treatment of advection and diffusion in the 
temperature, concentration, and vorticity equations, 
using an alternating-direction implicit (ADI) 
formulation . 

2. Solution of simultaneous equations determining the 
changes in the temperature, concentration, and 
interface . 

3. Implicit treatment of internal gravity waves. 

4. ADI iterative solution for the change in the 
stream- function, with a correct inclusion -of the 
no-slip conditions. 

To clarify the methods involved, we consider three simplified problems 
in this chapter. We then present the temporal staggering of the 
variables, outline the algorithms, and describe the details for our 
problem, in the following chapter. 


6.1 IMPLICIT ONE -DIMENSIONAL TEMPERATURE AND INTERFACE ALGORITHM 

In order to present our method for the simultaneous updating of 
the temperature, concentration, and interface, we first discuss a 
simplified problem, in one dimension. 


6.1.1 Definition of the Problem 

We simplify the problem by assuming no motion or concentration or 
ampoule, only one dimension (no radial variation), zero melting point 
and latent heat, and other melt and crystal properties unity. 
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The equation is simply the one - dimensional diffusion equation 
T = ^T , 

with the boundary conditions of imposing the temperature at the top 
and bottom. The melting interface is passive. 

The initial temperature profile should be monotonic, at least 
near the melting point, so that there is no uncertainty about its 
location. The numerical solution of this problem is of course 
trivial . 


6.1.2 Structure of the Spatial Representation 


We will seek to solve this problem using an unnecessarily 
complicated mesh which follows the melting interface, as in the 
previous chapter. The spatial representation becomes 

<^zT - fvj^ K T k - S k (^ z kS* k T) = 0 , 

The boundary conditions at the top and bottom are 



The interface conditions are similar to those at the 
boundary and at the interface in the previous chapter, 
is discontinuous. We extend the definitions of T^ and 
half a mesh interval the other side of the boundary, 
interface temperature as the mean, 


sample - ampoule 
Note that 
T^ to points 
and define the 



0 . 


The interface heat 
variables , 


( 




flux is the 





same using the upper and lower 


The following points should be noted concerning this spatial 
representation. 


1 . 

There are NZ+NZS interior temperature points 
equations . 

and 

2. 

There are two exterior temperature 
temperature boundary conditions. 

points, and 

two 

3. 

There are two additional unknowns at 
three equations. 

the interface, 

and 
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4. The temperature equation at each interior mesh point 
involves f. 

5. The interface temperature condition determines f. 

6. The number of equations matches the number of unknowns. 

7. The linear heat equation has been transformed into a 
nonlinear system by using a mesh which moves with the 
solid-liquid interface. 


6.1.3 Requirements for the Time Representation 

We will impose the following two requirements. 

1. The method should be unconditionally stable and second 
order accurate in time, so far as practicable, in order 
to allow the large time steps required for efficient 
modeling of prolonged experiments, without significant 
loss of accuracy. This effectively requires an 
implicit representation of the Crank -Nicolson type. 

2. The method should be readily and efficiently 
generalized to the full problem. This excludes an 
iterative method for solving a nonlinear system in the 
new variables or the changes. 


6.1.4 Time Staggering of the Variables and Algorithm Outline 

The variables T and f are represented by their values at discrete 
time steps, with a time interval At- A single time step starts with T 
and f at an initial time, together with the previous change A f, and 
replaces them by the new values and the new change Af . 

The following table shows the relative positions of the different 
variables in time, with time increasing down the page. The primary 
variables T, f and Af are specified at the initial level, and half a 
step back for f. 

Each advance of two rows then corresponds to a single time step. 
The evaluated quantities shown in the table are obtained in order and 
used to update the primary variables, as outlined below. 
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PRIMARY VARIABLES EVALUATED VARIABLES 

Af 

f T 

Af f f T 

v- n. 

f T 

For each successive time step, the algorithm consists of the 
following stages. 

1. Get the temporary second-order approximation 
f cc = f + Af/2, at the intermediate time level. 

2. Get the temporary first-order approximation f vv = Af/At, 
at the intermediate time level. 

3. Set up and solve a set of simultaneous linear equations 
for the change Af and the changes AT. 

4. Update f, by adding Af to the old value. 

5. Update T, by adding AT to the old value. 

Details are given in the following subsection. 


6.1.5 Implicit Time Representation 

Our representation is 

\zAr/At - Af/At^J^ - f^^AT^ - ^{^kS^T+^Ar)} = 0 . 

where ^ k is evaluated using the approximation f*, at the intermediate 
time. The parameter /3 is 0.5 for Crank -Nicolson second-order 
accuracy . 

The representation of the top and bottom boundary conditions and 
of the interface conditions is straightforward. 

This representation is fully second order accurate. The linear 
system can be solved for the unknowns AT and Af , using the familiar 
tridiagonal algorithm, appropriately generalized to include the single 
unknown Af . 
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6.1.6 Di scussion 

In both the illustrative problem and the full problem, the 
position of the interface is determined by the instantaneous 
distributions of T (and x for the full problem) near the interface. 
The motion of the interface and the rate of change of the temperature 
are directly related. 

For very small time steps, this method is essentially equivalent 
to an explicit method. The time derivatives are determined from the 
temperatures, concentrations, and interface position at the beginning 
of the step, and are influenced only by their neighbors. 

On the other hand, for very large time steps, the time 
derivatives play a smaller role in the representation, and we are 
determining an approximate steady state solution in one step, within 
the limits of the linearization. Naturally, for very large steps, 
accuracy in time is limited, but convergence to a steady state is more 
rapid. Time - stepping with a very large step is a possible method for 
obtaining steady-state solutions. A more powerful method is related 
to time stepping, but with time steps which vary from mesh point to 
mesh point and which are different for different variables. 

In the above one - dimens ional algorithm, distinct time steps could 
be used for T and for f, and they could be allowed to vary with 
position. In particular, larger time steps are appropriate in regions 
where the mesh is coarse. It is therefore natural to make the time 
step proportional to imposed powers of d^r and d^ , with the powers 
specified by input to the computer code. 


6.2 IMPLICIT INTERNAL GRAVITY WAVE ALGORITHM 

To illustrate our method for the stabilized treatment of internal 
gravity waves, we consider a simplified problem, in Cartesian 
two-dimensional coordinates. 


6.2.1 Application to the Linearized Equations 

We first consider the linearized internal gravity wave equations, 
with no diffusion or interface. The equations are 

“ - V ■ 

p = N"^ u , 

v x i(i + a = o , 

where N is the Vaisala frequency of internal gravity waves. Hence 

X - ' 

Viji + Nou=0 . 

9 • 
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An explicit leapfrog staggered representation of the equations, 
with time step At, leads after elimination of variables to the 
equation 

+ (NAtfVb = 0 , 

where o is the usual central difference operator with respect to 
time. In this and the following equations, the spatial derivatives 
are notations for their f ini te - di f f e r ence representations. This is 
only stable if (NAt) 2 '< 4 , which is an unduly restrictive limitation. 
However, if we use the second-order accurate stream- function equation 
formulation, 

a 

(V* + aN^At 1 ) u + to = 0 , 
then on elimination, 

+ aN^At 2 ^ )u + N^At^o^u = 0 , 
which is stable provided 

N^At 1- < 4(1 + aN*At a ) . 

This requires 

a > 1/4 - l/(NAt)' i . 


It can be shown that this representation of the eliminated u 
equation is fourth order accurate in time if a is 1/12. It is 
therefore natural to choose a as the largest of 1/12 and the above 
value . 

If N At is large compared with unity, this representation is of 
course poor for the high-frequency waves with the wave fronts almost 
vertical. However, if there is no significant forcing of these 
high-frequency modes, the representation can be highly satisfactory. 


6.2.2 Generalization to the Nonlinear Equations 

Since the above method only involves a slight modification of the 
Poisson equation for the stream- function, it is readily generalized to 
the nonlinear problem, and to cases with diffusion. Provided an 
implicit representation of the Crank -Nicolson type is used for the 
advection and diffusion terms, the stability criterion derived above 
remains sufficient. 

In our generalization to the full problem, we retain this 
formulation, and use the Vaisala frequency given by 
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The numbers 1/4 and 1/12 are replaced by input parameters, for greater 
flexibility. Modifications are required if the flow is strong. 
Further, there may be local regions with a density inversion (N 
negative); so we use the absolute value in applying the algorithm. 

This method was successfully applied by Roberts and Rubenstein 
(1981) to a two-dimensional problem with nonlinear advection but no 
diffusion, and with N t values as large as 20. Even larger values may 
be required with the present code. 


6.3 IMPLICIT VORTICITY ALGORITHM FOR A NO-SLIP CARTESIAN PROBLEM 

Our system includes the vorticity equation in two dimensions, 
with a no-slip condition on two boundary segments. Since we wish to 
use time steps with VAt much greater than the square of the smallest 
mesh interval, we must use implicit methods. To illustrate our method 
of solution, we consider first a fixed Cartesian geometry and a 
uniform mesh. 

The domain is i x ! < a , |y <b. The equations are 
U + V . ( utt - >)Vto ) = 0 , 

+ to = 0 . 

The boundary conditions are 
u = 0 , 

= 0 , 

on all four boundaries. There is no direct boundary condition on to; 
the boundary values required for the derivatives near the boundary are 
determined from iji and the additional boundary condition on 

The spatial representation is straightforward, using a uniform 
mesh such that the boundaries are mesh surfaces. For ill, the mesh 
extends one point beyond the boundaries, to allow a centered 
difference representation of the boundary condition, and thus to allow 
the centered evaluation of to on the boundary. 

Our Crank -Nicolson representation of these equations uses an 
extrapolation from previous steps to obtain the stream function and 
hence the flow u at the middle of the step. We then have 

[i + ^ 3 At ( u . v - yv z )]^to = At( - u.vw + yv^to) , 

[ -v a ]Au - kto = o , 

with the boundary conditions 
\ji = 0 , 
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^ lii = 0 . 

r\ 

The derivatives are now a notation for the natural central difference 
representations. The parameter /3 is 0.5 for second order accuracy in 
time. The right hand side is the known value from the previous step; 
the changes on the left are the unknowns. 

This linear system can be solved iteratively or by a direct 
method. We have considered the use of an alternating-direction 
implicit (ADI) iteration, but have adopted a direct method instead. 
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TIME STEPPING ALGORITHM 


In this chapter we present our algorithms for time stepping the 
equations for the spatial representation presented earlier. These 
algorithms combine the features illustrated in the previous chapter. 


7.1 TIME STAGGERING OF THE VARIABLES AND ALGORITHM SUMMARY 

The variables are represented by their values at discrete time 
steps, with a constant time interval At . The motion variables u and «o 
are represented at times half a step away from those for the variables 
f, T, and x. Note that these sets of variables are similarly 
staggered in space, in both coordinate directions. 

In addition to initial conditions for f, T, and x, and for u half 
a step behind, the previous value for Af and the new value for Au must 
be provided, so that second order accuracy can be maintained. It is 
reasonable to set the changes to zero for initial conditions. 

For a restart, this group of distributions must be saved, and 
reinitialized. 

To complete the initialization, it is necessary to compute the 
material properties, such as the conductivities K. 

A complete time step then advances all these variables by fat, to 
the values at the next time step. 

The following table shows the relative positions of the different 
variables in time, with time increasing down the page. Each advance 
of two rows corresponds to a single time step. The first two rows 
must be specified in the initialization, or from the previous step. 
The successive stages of a time step are shown in the table and 
outlined below. 
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STEP PRIMARY VARIABLES 


0 ifi Af 

0 . 5 £u f T x 


1 u Af 

1 . 5 Au f T x 


EVALUATED VARIABLES 


K 

^ z f^ AT Ax U 

K 2 ^ 


Table 7.1 Time Placement of the Primary and Evaluated Variables 


For each successive time step, the calculation proceeds as 
follows . 

1. Update u to the new time step, by adding Au. 

2. Get the temporary second-order approximation 
f^ = f + Af/2, at the intermediate time level. 

3. Set up the vertical mesh, using f^. This is indicated 
in the table by a z on row 1. 

4. Get the temporary first-order approximation f t ,_ = Af /At , 
at the intermediate time level. 

5. Set up and solve a set of simultaneous linear equations 
for the changes Af , At, and Ax. This is easier said 
than done . 

6 . Get a, from u. 

7. Update f, by adding Af to the old values. 

Simultaneously get the second order approximation f^., 
at the new time level, by extrapolating the old and new 
A^ values. 

8. Update T and x by adding AT and Ax to the old values. 

9. Update the temperature and concentrations at the 

interface, maintaining consistency with the equations 
of state. 

10. Get the material properties (signified in the table by 
the single variable K) from T and x. There is an 
option not to do this every time step, since often they 
are constants or change very slowly. The buoyancy and 
the interface concentrations must normally be updated 
every time step. 
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11. Set up the new vertical mesh, using f. 

12. Extrapolate the $ values to get tji^, for advection of 
momentum . 

13. Get Au from the vorticity and stream function equations 
and boundary conditions. Again, this is easier said 
than done . 

Details are given in the following sections. 

7.2 TEMPERATURE, CONCENTRATION, AND INTERFACE 
7.2.1 Equations 

Our time representation of the system of equations for the 
temperature, concentration, and interface is analogous to the 
representation of the one -dimensional temperature equation described 
earlier. We solve a set of simultaneous linear equations for the 
changes Af, AT, and Ax, and use them to update the interface and the 
concentration and temperature distributions. 

Our spatial representation for the concentration equation is 

Vx - rd^ r f + ^C^ = 0 , 

C c = - "x^^u - o^rd r i (^ k z5^_x - y O^f £j/x ) , 

Cj^ = x* b \ u - ^^[^xd ^r^kfl + (yb r f) } - tj x ^ ^_f ] . 

To represent this equation with second order accuracy, at the mid 
point of the time step, we use the following representations 

x Ax /At 

f Af/At 

Use f cv _ to get vertical mesh 
(Af/At + f^o^tySAx ) 

Latest value is at the right time 

x x + /3Ax 

» 


\ z 

fS t x k 
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f f + pts. 

The resulting nonlinear system is linearized by dropping the nonlinear 
terms, which are all second order. The resulting equation links nine 
Ax values, in a 3x3 square surrounding the point, and three Af values, 
surrounding the same i point. 

The temperature equation representation in the melt, crystal, and 
ampoule, is similar, with the same differences as were listed in 
Section 5.4.1. In the ampoule, there is a single unknown Af^_, which 
is a linear combination of three sample Af values. 


7.2.2 Boundary and Interface Conditions 

The boundary conditions on the concentration at the top, axis, 
and ampoule are represented using the same replacement for x as given 
above. The boundary conditions and ampoule - sample interface 
conditions for the temperature are represented similarly. 

In the interface conditions, we replace Tj , x^, and x c by 
Tj. + , \>+{3( dx^/dTjAl^ , and x c +y3( dx c /dT )&T 2 . 

Thus we obtain a closed linear system, with the same number of 
equations as unknowns. The system is analogous to the system 
described in Chapter 6, but of course it is much more complex. 


7.2.3 Solution of the System 

This system of linear equations is solved by Gaussian 
elimination. By making use of the sparse character of the matrix, the 
number of arithmetic operations per mesh point is reduced to 
approximately the square of (NR + NRA) . However, this is still high, 
for the anticipated resolution requirements. We have obtained a 
further reduction by decomposing the matrices used to eliminate the 
unknowns x and T away from the interface. This stage need only be 
repeated perhaps once every 30 steps. 

Iterative methods could be used to solve the system. Since for 
cases with gravity, the solution of the equation of motion requires a 
substantial number of iterations at each time step, the use of an 
iterative method here would not be unreasonable. 

We tried to develop a successful iterative scheme for a long 
period, without success. The failure does not indicate that it is 
impossible, and we hope to return to this if resolution becomes 
limited by the demands the present algorithm puts on our computer 
resources . 
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7.3 EQUATION OF MOTION 

7.3.1 Objectives of the Time Representation 

Our overall objectives are unconditional stability and second 
order accuracy in time. These are ambitious objectives, in view of 
the following special difficulties associated with the equations of 
motion : 

1. The incompressibility condition, requiring us to solve 
a Poisson equation for the stream- function ; 

2. Very strong maximum density stratification in most 

cases with gravity, requiring implicit treatment of 

internal gravity waves. 

3. The cylindrical geometry, the sloping and moving 

bottom, and the non - o r thogonal time - dependent 

coordinates ; 

4. No-slip boundary sections, so that the boundary 

condition cannot be expressed in terms of vorticity 

alone . 

These objectives cannot be achieved without a fairly 
sophisticated iterative motion algorithm, as outlined in the following 
subsections . 


7.3.2 The Vorticity Equation 

Our time representation of the vorticity equation is partially 
analogous to the representation of the one -dimensional temperature 
equation described earlier. We would like to solve the system 

d i r^j_. zAu)/At - d- u r^f = 0 . 

where and C^. are representations of the fluxes of (ul/r ) crossing 
the respective boundary segments, formulated to be second order 
accurate in time. 

The spatial representations of C t - and C* were described in three 
parts, corresponding to the advection terms, the buoyancy terms, and 
the diffusion terms. 

The buoyancy fluxes are 
C; « + ( g/fo )p k ^k z ' 
c k = ■ (g/ /°« • 
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The quantities f, z, and £ (a material property) are already available 
half way through the step, as shown in the table and algorithm outline 
above . 

The advection fluxes are written as 

r _\k 

Ci = - [(<A+p&iA)/r] d k u t ^ , 

^ c -ik 

= + [(w+^Ad)/r] o^o. • 

In these equations, da. is obtained by extrapolation from the earlier 
primary variables, as shown in the table. 


The vorticity diffusion flux terms are 
C; = - (\J k /r )d f i [^z&^ (Wr ) - «r^f <^(wr)^] , 

C K = - (\>Vr) [<^((0 r)d. rV t k{l + (^ r f ) X } - pb r fS c (wr ] . 

All terms in these expressions are already available with second order 
accuracy at the appropriate time, except for (Wr). We replace by 



This representation couples nine ^0 unknowns, in a 3x3 square 
surrounding the point. Boundary conditions are required to determine 
I y.t on the four boundaries of the melt. Since boundary conditions on W 
directly are not available on the ampoule or the crystal, the boundary 
conditions have to be considered together with the stream function iji, 
as described in the following subsection. 


7.3.3 The Stream Function Equation 

We take the difference in time of the st ream- function equation in 
Section 5.7, and linearize the right hand side, to obtain an equation 
for Aw in terms of the surrounding Ad, plus a nonhomogeneous term. We 
similarly take the difference of the boundary conditions. This gives 
a closed system in Aw and Au, with the same number of equations as 
unknowns . 


7.3.4 Solution Of The Equations 

We have investigated two methods for solving this linear system, 
iteration (using an alternating direction implicit algorithm) and 
direct Gaussian elimination (using a banded matrix algorithm to take 
advantage of the sparse nature of the system) . Our attempts at an 
iterative scheme have not succeeded, although this method is known to 
work in a Cartesian geometry. We are therefore implementing a direct 
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solver. We are using an L-U matrix decomposition, which is updated 
perhaps every 30 steps, for computational economy. The computational 
effort per mesh point is thus reduced; it would otherwise be of order 
the square of NR. 
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INPUT DATA FOR THE CODE 


The default data page is shown on the following page. The code 
is used to create this file, which contains default values. The 
default values represent a fairly easy model problem, minor variations 
of which are studied in the following chapter on our numerical 
results. The default file is edited to specify the required parameter 
values. The parameters are divided into four groups: problem; 
material properties; method; and output. 

The text at the top left (defaulting to SETUP DATA) is read in as 
a label, and later printed or plotted with the output, as in the plots 
shown later. 


8.1 THE PROBLEM PARAMETERS 

The problem parameters are the first group on the data page, and 
define the geometry and mesh and the external forcing. The DR and DZ 
parameters control the non - uni f ormi ty of the mesh in each direction 
and near each boundary and interface; they are the distinct parameters 
called a in Section 5.1. ZINTI and ZINTL are initial values for z- 
and Lj, for the z coordinate transformation. 

The top and bottom furnace temperatures apply above and below the 
corresponding z values, while the ampoule is insulated between them. 
The temperature boundary condition on the ampoule is smoothed over 
ZTBSC mesh intervals, as described in Chapter 5. If ZTBSC is zero, 
the unsmoothed boundary condition is applied. If ZTBSC is -1, this is 
a flag to impose the linearly interpolated temperature, between the 
two furnaces, as described in Chapter 4. 

WAMP is the downward speed of the crystal and ampoule relative to 
the furnace. GTERR is the downward gravity; it is zero for Spacelab 
simulations, and can be negative to simulate cases with the melt below 
the crystal. CTOP is the inflow concentration x T at the top of the 
furnace. DENCBM is the ratio ^> c of the crystal density to the melt 
density. 
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8.2 THE MATERIAL PROPERTIES PARAMETERS 

The material properties are as follows: 

o the specific heat CP for the three regions; 

o the conductivity COND for the three regions; 

o the interface latent heat as a function of the 
temperature ; 

o the interface melt concentration as a function of the 
temperature ; 

o the interface crystal concentration as a function of 
the temperature; 

o the relative density p/p a , which is multiplied by GTERR 
to give the downward acceleration; 

o the diffusivity for concentration, c<; and 

o the kinematic viscosity V. 

These functions are constants if the control is unity, otherwise they 
are calculated from the temperature and/or the concentration based on 
the integer control value and the parameters. Thus the decimal digits 
of the control parameter 124 indicate that the property is a four-term 
power series in T, plus the product of the concentration with a 2-term 
power series, plus the product of the square of the concentration with 
a 1-term power series in T (i.e. a constant). 

The interface properties can also be expressed as functions of 
the concentration, with the flag being a negative control parameter. 
The properties are then as follows: 

o latent heat as a function of the melt concentration; 

o temperature as a function of the melt concentration; 

o temperature as a function of the crystal concentration. 


The constant in the relative density has no effect on the flow. 
It should normally be set to zero, to reduce rounding errors in the 
finite differences. 


8.3 THE METHOD PARAMETERS 

The first method parameters are the number of time-steps or 
iterations and the logical variables to control whether the 
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concentration and flow are to be updated. 

The next row has time steps for temperature in the solid part of 
the sample (crystal) and in the ampoule. The objective in allowing 
distinct time steps is to get rapid iterative convergence to a steady 
state . 


The next three rows of parameters are for the melt temperature, 
concentration, and velocity. The first three parameters control the 
time step, for iterating to a steady state. In this case, more rapid 
convergence can be obtained by taking larger steps for concentration, 
with smaller diffusivity, and by taking smaller steps where the mesh 
spacing is smaller. For concentration, TAUC is the maximum of the 
time step, and it varies with the powers PCR and PCZ of the mesh 
spacings dr/di and d^/dk . 

The next parameter in each row controls the extent to which 
upwind differencing may be used if the flow is strong. The logical 
variables control whether the implicit tridiagonal division ("fixing") 
is applied to each variable in each direction, and are not used at 
present, since we only have the Gaussian elimination method. The BET 
parameters control the amplitude of the advection and diffusion terms 
in the implicit algorithm. The value 0.5 corresponds to the 
Crank-Nicolson algorithm, with second order accuracy in time and good 
stability properties. 

The first three method parameters on the last row are the time 
step and radial power for the interface function f, and the beta value 
for the implicit terms. The following three integers are the step 
intervals for updating the matrix decompositions, for flow, 
temperature, and concentration, respectively. It is computationally 
efficient not to do this every step. The frequency is automatically 
increased at the beginning of a computation. The last two method 
parameters are the factors of a quarter and a twelfth, used in the 
internal gravity wave algorithm. 


8.4 THE OUTPUT PARAMETERS 

The output parameters control different types of output. The 
direct access write and read option is used both for restarts of the 
calculation and for post -processing to obtain plots. The remaining 
rows of parameters control the printer and plotter output options and 
other diagnostics. Many are self-explanatory, but we will not give 
details of all the available options in this report. 
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COMPUTER USAGE 


9.1 COMPUTER SYSTEMS 

The code development was mostly done on our microcomputer system. 
The code is one of a family of computer codes which we routinely run 
both on this system and on three VAX minicomputers at MSFC (MIPSl and 
Mi ps 4 in HOSC , and the SSL VAX in Space Sciences Lab). These VAX 
computers are made available to us for NASA- sponsored work. We 
anticipate implementing some of these codes on the new Cray XMP 
computer in the future, for the convenience of our customers. 

The microcomputer calculations take about 10 times as long as 
those done on an empty VAX. Naturally, we do not do intensive 
computations on the VAXes during the working day; if we did, the speed 
would be comparable with that of the micro. 

Our VAX plots use Tektronix 4014 terminals and the TCS plot 
package, with our own interfaces. On the micro, we have implemented a 
TCS simulation on the dot matrix printer. 


9.2 CODE USAGE AND INPUT DATA 

Code usage on the two systems is very similar. The command 


C BS 

sets the environment. The command 
CUP B 15 40 10 25 

sets up the dimensions NR, NZ , NRA, and NZS xn the common file of 
FORTRAN statements which are included automatically in every 
subroutine. The command 


CALL 

compiles all the subroutines. The command 


9-1 



i 


COMPUTER USAGE 


CG PD 

can be used to recompile the subroutines in the particular file PD, 
for example. The command 

LGO B 15X40 NG 

links the compiled subroutines into an executable program. The 
parameter NG stands for NO GO. To execute the program with null data, 
use the command 

GO B 15X40 NULL 

This produces the output file SETP.DAT printed in the previous 
chapter. We refer to this file as the data page. Copies of this 
file, with different names such as SALT.DAT, are edited and then used 
as input by the command 

GO B 15X40 SALT 

This command produces both printed output and computer files for later 
executions of the program to read. The command 

LGO B 15X40 SALT CON 

is used to link and execute the contouring program (CON) which 
produces plots from the output of the previous run. 
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CHAPTER 10 


NUMERICAL RESULTS 


In its new form, the code can be 
according to the input data: 


run in one of four modes. 


1. Temperature alone; 


2. Temperature and convection; 

3. Temperature and concentration; and 

4. Temperature, convection and concentration. 

We have not presented any convection cases, as we are not yet 
satisfied with our algorithms; the flow routines presented in the 
appendix are an initialization to satisfy the boundary conditions, and 
dummy routines. 

In this chapter, we present numerical results for two test 
problems, with temperature and concentration included. The two 
problems were the default case, with data listed in the previous 
chapter, and a minor modification, with smaller concentration and 
solute diffusivity. 


The sample and ampoule diameters are 2 and 4 mm, respectively. 
The furnace ends are 2 mm apart, and the computational boundaries at 
the top and bottom are 4 mm apart. The top and bottom temperatures 
are 50 and -100 degrees. The ampoule speed is 0.001 cm/sec, or 3.6 
cm/hour . 

The material is nominally water, with zero melting point and 
latent heat 80 calories per cc of melt. The volume specific heats are 
1.0, 0.5, and 0.1, respectively, for the melt, crystal, and ampoule, 
in units of cal/cc/deg. The respective conductivities are 14, 10, an- 
8, in units of 0.0001 cal/cm/sec/deg . The ratio of the crystal 
density to the melt is 0.9, so the material expands on solidifying. 


The phase diagrams shown in Chapters 3 and 4 
that increased the melting point. Our test solute, 
the melting point, and is rejected as the crystal g 


were for solutes 
however , decreases 
rows, leading to a 
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solute excess ahead of the interface, cf. Figure 3.2. Melt 
20% concentration is in equilibrium with crystal with 
concentration, at a temperature of -20 degrees. 

For our model material, the buoyancy is linear in the temperature 
and concentration . However, we have not computed the convection flow, 
as stated above. 


wi th a 
a 2% 


10.1 CASE 1: HIGH INPUT CONCENTRATION AND DIFFUSIVITY 

For our first test case, we used a solute concentration at the 
top of 2%. With our state diagram, this implies a crystal 
concentration of 2%, and a melt concentration at the interface of 20%, 
at a temperature of -20 degrees. 

The diffusivity was 0.0001 cm /sec. With the ampoule speed of 
0.001 cm/sec, the length scale of the diffusion layer in the melt 
(neglecting the flow modification due to the expansion on 
solidification) is , or 1mm. An estimate for the parameter 

( dT/dz )/( dx/dz ) at the interface is -250, which is greater than the 
slope of the melt line in the equation of state (-100). Thus 
dendrites should not form. 

The following three figures show our steady state solution. 

Figure 10.1 shows the computational mesh. We used 
NR = 8 , 

NZ = 25, 

NRA = 6 , 

NZ S = 15. 

Our choices of the DR and DZ input parameters gave a fine mesh near 
the interface and near the sample boundary, in order to resolve fine 
structure there withiut wasting mesh points elsewhere. 

Figure 10.2 shows the temperature solution. The interface 
temperature varies between *18.1 and -19.5 degrees, at the ampoule and 
at the axis respectively. This corresponds to variations in the 

concentration. The melt concentration is one hundredth of the 
temperature magnitude; the crystal concentration is one thousandth of 
the temperature magnitude. The crystal surface is concave, due to 
latent heat release (a significant factor in this case), the lower 
conductivity of the crystal, and the fact that the temperature is 
approximately half way between the top and bottom tmperatures. 
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Figure 10.3 shows the steady * state solution for the 
concentration. The balance is between downward advection and upward 
diffusion. The flow is the ampoule flow, modified by the expansion of 
the melt as it freezes, which leads to a small superposed Poiseuille 
flow up the cylinder. The thickness of the diffusion layer agrees 
with the predicted value of 1mm. This thickness is too large for 
dendrites to form, even at these large concentrations. The maximum of 
the concentration is 19.5%, on the interface and at the axis. The 
minimum is of course the imposed value of 2% at the top. 


10-3 



NUMERICAL RESULTS 
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CONCENTRATION IN THE MELT 
SALT AND UATER TEST/. 02/. 0001 
MAXIMUM - 0. 19504 
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Figure 10.3 Concentration for High Concentration and Diffusivity 
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10.2 CASE 2: LOW INPUT CONCENTRATION AND DIFFUSIVITY 

For our second test case, we used a solute concentration at the 
top of 0.1%. With our state diagram, this implies a crystal 

concentration of 0.1%, and a melt concentration at the interface of 
1%, at a temperature of -1 degrees. 

The diffusivity was 0.00001 cm /sec. With the ampoule speed of 
0.001 cm/sec, the length scale of the diffusion layer in the melt 
(neglecting the flow modification due to the expansion on 
solidification) is ek/W^ , or 0.1mm. An estimate for the parameter 
( dT/dz )/( dx/dz ) at the interface is -500, which is greater than the 
slope of the melt line in the equation of state (-100). Thus 
dendrites should not form. 

The following three figures show our steady state solution. 

Figure 10.4 shows the computational mesh. We again used 


NR = 

NZ = 

NRA = 

NZS = 

Our choices of 
the interface 
structure there 
different from 
different . 


8 , 

25, 

6 , 

15. 

the DR and DZ 
and near the 
withiut wasti 
the previous 


input parameters gave a 
sample boundary, in order 
ng mesh points elsewhere, 
case, of course, because 


fine mesh near 
to resolve fine 
The mesh is 
the interface is 


Figure 10.5 shows the temperature solution. The interface 
temperature was -1 degrees, with very little variation. The crystal 
surface is less concave. The latent heat release and the lower 
conductivity of the crystal are the same as before, but the interface 
temperature is much closer to the upper imposed temperature, and this 
tends to make the crystal convex. 


Figure 10.6 shows the steady-state solution for the 
concentration. The balance is between downward advection and upward 
diffusion. The flow is the ampoule flow, modified by the expansion of 
the melt as it freezes, which leads to a small superposed Poiseuille 
flow up the cylinder. The thickness of the diffusion layer agrees 
with the predicted value of 0.1mm. This small thickness is still too 
large for dendrites to form, due to the low concentration. • L *" ie 
maximum of the concentration is 1%, on the whole interface. The 
minimum is of course the imposed value of 0.1% at the top. 
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Figure 10.4 Computational Mesh for Low Concentration and Diffusivity 


10-8 


NUMERICAL RESULTS 


TENPERATURE IN THE WHOLE SYSTEPI 
SALT AND WATER TEST/. 001/. 00OO1 
MAXiiiun - 50.000 

minimum - - 100.00 

INCREMENT - 8.0000 

TINE - 50.000 



Figure 10.5 Temperature for Low Input Concentration and Diffusivity 
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Figure 10.6 Concentration for Low Input Concentration and Diffusivity 
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APPENDIX A 


CODE LISTING 


The FORTRAN code is listed in the following pages. There are 
sixteen files, P., Pi., P2 . , P3., PCON., PD., PG., PI., PP., PPl., 
PT., PTl . , PT2 . , PT3 . , PT4 . , and PU., containing subroutines specific 
to this code. ' The file COM. contains the common blocks and other 
FORTRAN statements which are automatically included in every 
subroutine. The program is self -documenting . 

The file P. contains the main program. Pi. through P3. contain 
init=ial=iz=ation routines, and P3. includes the routine calls for 
direct access input and output. PCON. contains a main program and 
subroutines for the various plot options. PD. routines provide 
numerical diagnostic lines for each time step. PG. contains the 
routines which control most output options. The PI. subroutine reads 
and writes the data page file. PP. and PPl. routines handle the 
material properties. Subroutines in the PT series of files handle 
updating the temperature, concentration, and interface. The 
subroutines in the PU series do the motion. 

The seven files, QB . , QC . , QCZ . , QE., QM., QVAX., and QZ . , 
contain general-purpose utility subroutines, used in a whole family of 
codes, and are not included. Nor is the PC substitute for QVAX. 

We use the TCS plot graphics software package on VAX computers 
and Tektronix 4014 terminals with hard-copy units. We use our own 
graphics software (also not included in the listing) to emulate the 
TCS package on a dot-matrix printer. 


A - 1 
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10 

20 

30 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 


360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


C 

C 

c 

c 

c 

c 

c 

c 


PARAMETER ( NR = 1 5 , NZ = 3 0 , NRA =9 , NZS = 20) 

PARAMETER ( NRPl=NR+l ,NRP2=NR+2 ) 

PARAMETER ( NRAPl=NRA+l , NRAP2=NRA+2 ) 

PARAMETER ( NRC=NR+NRA , NRCPl=NRPl+NRA , NRCP2=NRF 2+NRA ) 

PARAMETER ( NZPl = NZ+l , NZP2=NZ+2 ) 

PARAMETER ( NZ S Pl=NZ S+ 1 , NZ S P 2=NZS+ 2 ) 

PARAMETER ( NZC=NZ+NZS ,NZCPl=NZPl+NZS , NZCP2=NZP2+NZS ) 
PARAMETER ( NMATPR=1 2 , NPRCON=8 , NAPC=20 ) 

CUP B 15 40 10 20 

ADDS A PARAMETER STATEMENT DIMENSIONING NR, NZ , NRA, NZS 
AND REPLACES THESE LINES PRl , etc., BY THE FILES: 

PROBl , PROB2, METHl , METH2 , AND OUTP . BC 

WHICH CONTAIN CONTINUATION LINES FOR I/O STATEMENTS IN INIT0 
AND FOR COMMON BLOCKS IN COMO TO MAKE THE INCLUDED FILE COM. 

COMMON /PROS./ 


210 

1 RINS , DRINS 

r? m 

, Zi i 

, DZT 

, TTOP 

, ZTTOP 



220 

1 , RSAM , DRSAM 

, ZB 

, DZE 

, T50T 

, ZTBOT 



230 

1 , RAMP , DRAMP I 

, ZINTI 

, DZ INTM 

, GTERR 

, ZTBSC 



240 

1 , DRAMPO 

, ZINTL 

, DZINTS 

,WAMP 

, CTOP 



250 

1 



, DENCBM 




260 

COMMON /METH/ 







270 

1 NSTEP , LC 

, LU 






280 

1 , TAUS , TAUA 







290 

1 , TAUT , PRT 

, PZT 

, TUPWND 

, FIXTR 

, FIXTZ 

, BETTA 

, BETTD 

300 

1 , TAUC , PRC 

, PZC 

, CUPWND 

, FIXCR 

, FIXCZ 

, BETCA 

, BETCD 

310 

1 , TAUU , PRU 

, PZU 

, UUPWND 

, FIXUR 

, FIXUZ 

, BETUA 

, BETUD 

320 

1 , TAUF , PRF 

, BEF 

, NUF 

,NTF 

, NCF 

, AQURTN 

, ATWLV 

330 

COMMON /OUTP/ 







3 40 

1 ISEGR , I SEGW 

, IBEGDA 

, I INC DA 

, NDI AG 

,NCLP 

, NCLI 


350 

1 , RSTRPL 

, ZBPL 

, ZTPL 

, NCOPY 





C 

c 


ORIGINAL PAGE IS 

OF POOR QUALITY 


LOGICAL FIXCZ , FIXCR, FIXTZ , FIXTR , FIXUZ , FIXUR , PRTEST , LC , LU , 

1 DI AG , TLOG , PPCHAN ,LCF,LTF,LLF, LUF 
COMMON /LOGIC/ 

1 DIAG, TLOG, PPCHAN, LCF,LTF,LLF, LUF 
CHARACTER *40 TEXPRG(4> 

CHARACTER *8 STITLE ( NAPC ) 

CHARACTER *42 LTITLE(NAPC) 

CHARACTER *44 DESCR 
CHARACTER *15 CMATPR ( NMATPR ) 

CHARACTER *20 CUNI TS ( NMATPR ) 

CHARACTER *28 JTIME 
CHARACTER *40 CGROW 

COMMON /CHAR/ TEXPRG , LTI TLE , STI TLE , DESCR , CMATPR , CUNI TS , JTIME , CGR 
INTEGER *4 MATPRT ( NMATPR ) 

COMMON /MATPRP/ PRPMAT ( NPRCON , NMATPR ), MATPRT 
COMMON /CPRNT/ ACONT ( NAPC ) , I PC ( 1 6 , NAPC ) 

COMMON /SCAL/ 

1 PI , ICASE , I STEP , NTYPE 
1 , IDAOUT , IDAIO , TTIME 
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590 

1 , IREC1R 

, IREC1W , NREC1 

, IREC1 

600 

1 , IREC2R 

, IREC2W , NREC2 

, IREC2 

610 

1 , I SEGRN 

, ISEGWN , I SEGRU 

, ISEGWU 

620 

1 , F INT , FRI TE 

, FBOT , FTOP 

, FSUM 

630 

1 , XINT , XTOP 

, XSUM 


640 

1 , DIDRAB 

, DKDZTC , DEDZTC 


650 

1 , DKDZMM 

, DIDRMS 


660 

1 , DKDZMC 

, DIDRMA 


670 

1 , TUPM , CUPM 

, UUPM 


680 

1 , TMELT 

, CMELT 


690 

1 , ZL , Z INT 



700 

1 , FAMP , DFAMP 

, NFABC ,FABC(3) 


710 

1 , AWALL 



720 C 




730 

COMMON /ARAYZ/ 



740 

1 ZETW(NZCPl) 

, DKDZTW ( NZCPl ) 

, DZTDKW (NZCPl ) 

750 

1 , ZETH ( NZCP2 ) 

,DKDZTH(NZCP2) 

,DZTDKH(NZCP2 ) 

760 

1 , ETAW ( NZ CP 1 ) 

, DEDZTW (NZCPl ) 

, DETDKW (NZCPl ) , ETA2W( NZCPl ) 

770 

1 , ETAH ( NZCP2 ) 

,DEDZTH(NZCP2) 

,DETDKH(NZCP2 ) , ETA2H ( NZCP2 ) 

780 

1 , TRBC ( NZCP2 ) 

, TRBM( NZCP2 ) 


790 

1 , TVBTZH(NZCP2 ) 

,CVBTZH( 

NZCP2) ,UVBTZW(NZCP2 ) 

800 

1 ,DKDZAH(NZCP2 ) 

, DKDZAW{ NZCPl ) , DZDKAH ( NZCP2 ) ,DZDKAW( 

810 

1 , ZAH ( NZCP2 ) 

, ZAW (NZCPl ) 


820 ■ C 




830 

COMMON /ARAYRl/ 



840 

1 RW(NRCPl) 

, DIDRW( NRCPl ) 

, RH ( NRCP2 ) , DIDRH( NRCP2 ) 

850 

1 , HBRDRH(NRCP2 ) 

,DRB2RW( NRCPl) , RDRWQH ( NRCP2 ) 

860 

1 , RDRB2H ( NRCP2 ) 

, RDRB2W { 

(NRCP2 ) 

870 

1 , RB2DRH ( NRCP2 ) 

, RB2DRW( NRCP2 ) 

880 

1 , R2W ( NRPl ) 

, R4W ( NRPl ) 


890 

1 , DFDRW ( NRP2 ) 

, DFDRH ( NRP2 ) 


900 

1 , RDRF8H ( NRP2 ) 

, RDRF8W ( NRP2 ) 


910 

1 , DRF8RH ( NRP2 ) 

, DRF8RW ( NRP2 ) 


920 

1 , ZDRFH ( NRP 2 ) 

, ZDRFW ( NRP2 ) 


930 

1 , WKl ( NRCPl ) 



940 

COMMON /ARAYR2/ 



950 

1 FINTH ( NRP2 ) 

,DFINTH(NRCP2) 

,RFINTH(NRCP2 ) , RFINTW ( NRCPl ) 

960 

1 ,DFINTW(NRCP2 ) 


5 970 

1 , TINTH ( NRP2 ) 

, CINTMH ( NRP2 ) 

, CINTCH ( NRP 2 ) , HEATLAT ( NRP2 ) 

: 980 

1 , DTINTH ( NRP2 ) 


- 

: 990 

1 , CPINTM ( NRP 2 ) 

,CDINTM(NRP2 ) 

, DINTH ( NRP2 ) 

j 1000 

1 , CP INTC ( NRP2 ) 

, CDINTC ( NRP2 ) 


1 1010 

1 ,DTFINT(NRP2 ) 

,DCFINT(NRP2 ) 

, TFZC ( NRP2 ) 

1020 

1 , DFTINT ( NRP2 ) 

,DFCINT(NRP2) 

, DTCINT ( NRP2 ) 

1030 

1 , DCMDT ( NRP2 ) 

,DTDCM(NRP2 ) 

,DCCDT(NRP2) , DTDCC ( NRP2 ) 

1040 

1 , DHLDT ( NRP2 ) 

, DHLDC ( NRP2 ) 


1050 

1 , TZ ICD ( NRP2 ) 

, TZICE ( NRP2 ) 


1060 

1 , TZICF ( NRP2 ) 

,TZICG(NRP2 ) 


1070 

1 , CTMULT ( NRP2 ) 



1080 

1 , TVBTRH(NRCP2 ) , CVBTRH 

( NRP2 ) , UVBTRW ( NRP2 ) , BTF ( NRP 

1090 

COMMON /ARAYR3/ 



1100 

1 TDRWH( NRCPl) 

,TGRWH( NRCPl ) 


1110 

1 ,TFRWH (NRCPl ) 

,TERWH( NRCPl ) 


1120 

1 , TDZHW ( NRCPl ) 

, TGZHW ( NRCPl ) 


1130 

1 , TFZHW ( NRCPl ) 

, TEZHW ( NRCPl ) 


1140 

1 , CDRWH ( NRP 1 ) 

, CGRWH ( NRPl ) 


1150 

1 , C FRWH ( NRPl ) 

, CERWH ( NRPl ) 


1160 

1 , CDZHW ( NRPl ) 

, CGZHW ( NRPl ) 
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1170 

1180 

1190 

1200 

1210 

1220 

1230 

1240 

1250 

1260 

1270 

1280 

1290 

1300 

1310 

1320 

1330 

1340 

1350 

1360 

1370 

1380 

1390 

1400 

1410 

1420 

1430 

1440 


1 , CFZHW ( NRPl ) 
1 , D2T ( NRCP2 ) 


, CEZHW( NRPl ) 
, D2C ( NRP2 ) 


COMMON /ARAY2/T ( NRCP2 ,NZCP2 ) 
COMMON /AR2A/ CP ( NRCP2 , NZCP 2 ) 
COMMON /AR2B/ C(NRP2,NZP2) 
COMMON /AR2C/ PSI ( NRP2 ,NZP2 ) 
COMMON /AR2D/ DVORT ( NRPl , NZPl 
COMMON /AR2E/ BUOY ( NRP2 , NZP2 ) 
1 , VI SC ( NRP2 , NZP2 ) 


, DT ( NRCP2 , NZCP 2 ) 

, COND ( NRCP2 , NZCP 2 ) 
, DC ( NRP2 , NZP2 ) 

, DPS I ( NRP2 , NZP2 ) 

, VORT ( NRPl , NZPl ) 

, DI FF ( NRP2 , NZP2 ) 


, PSIO ( NR 


PARAMETER ( NCB=2*NR+3 ,NTB=2*NRC+3 , NAI=5*NR+2*NRA, NAI S=3 *NR+2 *NRA 
COMMON /ARG/ 

, CRG ( NRP 2 , NZ P 2 ) 

i »T-n n'l \ 


CRD ( NRP2 , NZP2 ) 

, CRE ( NRP 2 , NZP2 ) 

, CZD(NRP2 ,NZP2 ) 

, CZE ( NRP 2 , NZP2 ) 

, CA ( NCB , NR , NZ ) 

, DCNG(NR,NZ ) 

, TRD ( NRCP2 , NZCP 2 ) 

, TRE ( NRP 2 , NZCP 2 ) 

, TZD ( NRCP2 , NZCP 2 ) 

, TZE(NRP2,NZCP2 ) 

, TA( NTB , NRC , NZC ) 

, DTNG( NRC , NZC ) 

, AI ( NAI , NAI ) , BI ( NAI ) 

INCLUDE ' LUTIL : KACH . INC ' 


1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 

1 


, CRF ( NRP2 ,NZP2 ) 

, CZG(NRP2 ,NZP2 ) 

, CZF (NRP 2 ,NZP2 ) 

, CF ( NR ,NR , NZ ) 

,TRG(NRP2,NZP2 ) 

, TRF ( NRP 2 , NZCP 2 ) 

, TZG ( NRCP2 , NZCP 2 ) 
, TZF ( NRP 2 , NZCP2 ) 

, TF ( NR , NRC , NZC ) 


: i 



a 

£ 


I 
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420 
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BRIDGMAN- STOCKBARGER CRYSTAL GROWTH CODE 

AUTHOR: GLYN ROBERTS 

ROBERTS ASSOCIATES, INCORPORATED 
1726 PINE VALLEY DRIVE 
VIENNA, VA 22180 
703/938-1757 

MONITOR: WILLIAM W. FOWLIS 

NASA/ES7 3 , MSFC, AL 35812 
205/544-7813 


ORIGINAL PAGE IS 
OF POOR QUALITY 


PROGRAM MAIN 

INCLUDE ' COM. /NOLIST' 

EXTERNAL IWRITE 

INITIALIZE 

LCONT = .FALSE. 

CALL SETUP 

CASE DO LOOP TERMINATES IN INITO WHEN DATA RUNS OUT 

DO 20 ICASE = 1, 100 

INITIALIZE TIMING AND CGROW 

CALL LIB$INIT_ TIMER ( I HAND ) 

CGROW = ' ' 

INPUT SEGMENT 

CALL INITO 

INIT2 INITIALIZES THE ARRAYS AND MESH, 

CALLS PRNT FOR THE INITIAL ARRAYS, AND 
INITIALIZES THE CALCULATION 

CALL INIT2 

TIME STEP LOOP 

DO 10 ISTEP = 1, NSTEP 

UPDATE TIME AND T, C, AND F. 

TTIME = TTIME + TAUT 
CALL TFSTEP 
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590 

600 

610 

620 

630 

640 

650 

660 

670 

680 

690 

700 

710 

720 

730 

740 

750 

760 

770 

780 

790 

800 

810 

820 

830 

840 

850 

860 

870 

880 

890 

900 

910 

920 

930 

940 

950 

960 

970 

980 

990 

1000 

1010 

1020 


C 

C UPDATE MATERIAL PROPERTIES 
C 

ISTEPM = MAX ( 1 , NSTEP/5 ) 

IF ( ISTEP/ISTEPM*ISTEPM . EQ . ISTEP) CALL SMATPR 
C 

C UPDATE FLOW 
C 

C CALL USTEP 

c STEPS COMPLETED FOR COPY, IN CASE OF GROWTH TERMINATION 

c 

NSTEPC = ISTEP 


C 

c 

c 


7 


GROWTH TERMINATION PROCESSING 


IF 


1 


( CGROW .NE. ' ') 

WRITE ( * , 7 ) 
WRITE (6,7) 
FORMAT ( / ' 

r 

GO TO 15 


THEN 

ICASE, ISTEP, CGROW 
ICASE, ISTEP, CGROW 
GROWTH TERMINATION ON CASE ',14, 
AT STEP ', 17 , 5X ,' CGROW = ',A/) 


ENDIF 


C 

10 CONTINUE 

C 

15 CONTINUE 

C TIMER STATISTICS TO STREAM 6 AND SYS$OUTPUT 
C 

CALL LIBSSHOW TIMER(IHAND) 

CALL LIB$SHOW_TIMER(IHAND, ,IWRITE) 

C COPY DIAGNOSTICS TO RESULT AND SUMMARY FILES 
C 


18 

C 

C 

C 

20 

C 


DO 18 IS = 
CALL COPY 


30 34 

( is' 6 , 16 ,NSTEPC + 1 ,NDIAG,NSTEP+1 , ( NLPP - NLMA ) /5 - 


END CASE LOOP 
CONTINUE 

CALL STOPP ('TOO MANY CASES%') 
END 


4 ) 
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10 

20 

30 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 

210 

220 

230 

240 

250 

260 

270 

280 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


SUBROUTINE SETUP 
C 

C OPEN UNITS AND INITIALIZE DATA PAGE DATA 
C 

INCLUDE ' COM. /NOLIST' 

C DATA BLANK /' '/ 

C 

C PROBLEM, METHOD, AND OUTPUT PARAMETERS ARE SET TO DEFAULTS, 

C AND CHANGED USING INPUT IN INITO . . ; 

C IF THE INPUT IS NULL, THESE DEFAULTS ARE USED TO WRITE SETP.DAT. 

C 

C SET MACHINE PARAMETERS IN COMMON BLOCK /MACHIN/ 

C USE A DIFFERENT VERSION ON EACH COMPUTER 
C 

CALL SMACH 
C 

C OPEN FILES FOR DATA, WORK, AND SUMMARY. 

C LCONT IS .TRUE. FOR CONTOUR. 

C 

OPEN (UNIT=5,FILE='FOR005' , STATUS= ' OLD ' ) 

CALL SQOPN (5,0) 

CALL SQOPN (16,1) 

C 

DO 1 J = 30, 34 
1 CALL SQOPN ( J , 1 ) 

C 

C GET TEXT FOR DATE AND TIME 
C 

CALL DATTIM ( JTIME ) 

C 

C COPY COMPLETE INPUT TO SUMMARY FILE. 

C 

WRITE (16,10) NR , NZ , NRA , NZ S , JTIME 

]_0 FORMAT ( ' 1BRIDGMAN - STOCKBARGER CODE COMPLETE INPUT DATA FILE 

1 ,T75, 'MESH' ,I3,3( ' , ' ,13) ,T100,A/) 

IF (.NOT. LCONT) CALL COPYP (5,16,137) 

C 

c PROBLEM PARAMETERS 

C 

DESCR = 'SETUP DATA' 

C 

C R DOMAIN 
C 

RINS = 0. 

RSAM = . 1 

RAMP = . 2 

C 

C R MESH BOUNDARY RESOLUTION REQUIREMENTS 
C 

DRINS = .1 
DRSAM = .03 
DRAMPI = .02 
DRAMPO = .06 
C 

c Z DOMAIN 
C 


ZT 

ZB 


2 

.2 
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590 

C 


600 

c 

Z MESH 

610 

c 


620 


ZINTI = 0 

630 


ZINTL = 0.5 

640 

c 


650 


DZT = .5 

660 


DZB = .5 

670 


DZINTM = .03 

680 


DZINTS = .03 

690 

c 


700 

c 

EXTERNAL PARAMETERS 

710 

c 


720 


TTOP = 50 

730 


TBOT = -100 

740 


GTERR = 980 

750 


WAMP = 0.001 

760 


DENCBM = .9 

~70 

c 


'0 


ZTTOP = .1 

79c 


ZTBOT = - . 1 


ZTBSC - 0.5 
CTOP « .02 


C 

C MATERIAL PROPERTIES 

C 

DO 20 IMAT = 1, NMATPR 
0 DO 20 K = 1, NPRCON 

. -0 MATPRT ( IMAT) = 1 

i30 PRPMAT( K, IMAT) = 0 

890 20 CONTINUE 

900 C 

910 C PROPERTY NAMES, UNITS, AND INITIAL DEFAULTS 
920 C 


930 


CMATPR ( 1 ) = 

' CPMELT ' 

940 


CMATPR ( 2 ) = 

' CPCRYS ' 

950 


CMATPR ( 3 ) = 

' CPAMP ' 

960 


CMATPR ( 4 ) = 

' CDMELT ' 

970 


CMATPR ( 5 ) = 

' CDCRYS ' 

980 


CMATPR ( 6 ) = 

' CDAMP ' . 

990 


CMATPR ( 7 ) = 

' LATHEAT' *• ' 

1000 


CMATPR ( 8 ) = 

' CINTM '• 

1010 


CMATPR ( 9 ) = 

' CINTC ' 

1020 


CMATPR (10) = 

'BUOYANCY' 

1030 


CMATPR (11) = 

' DIFFUSIVITY' 

1040 


CMATPR (12) = 

'VISCOSITY' 

1050 

i ac n 

1WUU 

C 

CUNITS(l) = 

Inal /n n /Ann t 
u d a/ ucy 

1070 


CUNI TS ( 2 ) = 

' cal/cc/deg ' 

1080 


CUNI TS ( 3 ) = 

' cal/cc/deg ' 

1090 


CUNI TS ( 4 ) = 

' cal/cm/sec/deg ' 

1100 


CUNITS(5) = 

' cal/cm/sec/deg' 

1110 


CUNITS(6) = 

' cal/cm/sec/deg' 

1120 


CUNI TS ( 7 ) = 

' cal/cc ' 

1130 


CUNITS ( 8 ) = 

' gm/gm ' 

1140 


CUNITS(9) = 

' gm/gm ' 

1150 


CUNITS (10) = 

' gm/gm ' . 

1160 


CUNITS ( 11 ) = 

: 'cm2/sec' 
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1170 

1180 

1190 

1200 

1210 

1220 

1230 

1240 

1250 

1260 

1270 

1280 

1290 

1300 

1310 

1320 

1330 

1340 

1350 

1360 

1370 

1380 

1390 

1400 

1410 

1420 

1430 

1440 

1450 

1460 

1470 

1480 

1490 

1500 

1510 

1520 

1530 

1540 

1550 

1560 

1570 

1580 

1590 

1600 

1610 

1620 

1630 

1640 

1650 

1660 

1670 

1680 

1690 

1700 

1710 

1720 

1730 

1740 


C 


C 


c 

c 

c 

c 

c 


CUNI TS (12) < 

MATPRT ( 8 ) = 
MATPRT ( 9 ) = 
MATPRT (10) : 

PRPMAT ( 1,1) 
PRPMAT ( 1,2) 
PRPMAT ( 1,3) 
PRPMAT ( 1,4) 
PRPMAT ( 1,5) 
PRPMAT ( 1 , 6 ) 
PRPMAT ( 1,7) 
PRPMAT ( 1 , 8 ) 
PRPMAT ( 1,9) 
PRPMAT ( 2,8) 
PRPMAT ( 2,9) 
PRPMAT ( 1 ,10 
PRPMAT ( 2,10 
PRPMAT ( 3,10 
PRPMAT ( 1,11 
PRPMAT ( 1 ,12 


' cm2/sec ' 

2 

2 

12 

= 1.0 
= 0.5 
= 0.1 
= 0.0014 
= 0.0010 
= 0.0008 
= 80.0 
= 0.0 
= 0.0 
=- 0.01 
=- 0.001 
= 0.0 
= - 1 . E - 4 
= 0.01 
= l.E-4 
= l.E-2 


NUMBER OF TIME STEPS OR ITERATIONS 
NSTEP = 50 


METHOD PARAMETERS 


C 

C LOGICAL VARIABLES TO UPDATE CONCENTRATION OR FLOW 
C 

LC = .FALSE. 

LU = .FALSE. 

C 

C TIME STEPS AND POWERS OF DR AND DZETA 
C FOR CONCENTRATION, TEMPERATURE, AND MOTION. 

C 

TAUT = 0.5 
TAUS =0.5 
TAUA =0.5 
PRT = . 0 
PZT = . 0 
C 

TAUC = 0.5 
PRC = .0 
PZC = .0 
C 

TAU'u = 0.5 
PRU = .0 
PZU = .0 

c 

C UPWIND DIFFERENCING COEFFICIENTS 
C 

CUPWND = 0.05 
TUPWND =0.0 
UUPWND = 0.0 
C 

C IMPLICIT LOGICAL CONTROLS. 
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1750 

C 




1760 

FIXCR = .TRUE. 


- 


1770 

FIXCZ = .TRUE. 




1780 

FIXTR = .TRUE. 




1790 

FIXTZ = .TRUE. 




1800 

FIXUR = .TRUE. 




1810 

FIXUZ = .TRUE. 




1820 

C 




1830 

C IMPLICIT FIXING AMPLITUDES. 




1840 

C 




1850 

BETCA = .7 




1860 

BETCD = .7 




1870 

BETTA = . 7 




1880 

BETTD = .7 




1890 

BETUA = .7 

*- 


1 

jj 

1900 

BETUD = .7 



1 

1910 

C 




1920 

C F STEPS 




1930 

C 




1940 

TAUF = 0.5 




1950 

PRF = 0. 




1960 

BEF = .7 




1970 

C 




1980 

C INTERNAL WAVE METHOD 




1990 

C 




2000 

AQURTN = .25 




2010 

ATWLV = 1./12. 




2020 

NPI = 10 




2030 

C 




2040 

C FREQUENCIES FOR UPDATING L-U DECOMPOSITIONS IN GAUSS 

ELIMINATION 



2050 

C METHOD FOR DT , DC AND DF. 




2060 

C 




2070 

NUF = 10 




2080 

NTF = 10 




2090 

NCF = 30 




2100 

C 



' 

2110 

c OUTPUT CONTROL 

PARAMETERS 


. 

2120 

C 




2130 

C DIRECT ACCESS OUTPUT AND INPUT. 



IN 

. x 

2140 

C ISEGR - READ SEGMENT FOR INITIAL CONDITIONS. ZERO FOR ANALYTIC. 

- 

* 

2150 

C ISEGW - FIRST WRITE SEGMENT. ’ 



.S 

2160 

C 




2170 

C -1 MEANS USE NEXT SEGMENT OF SAME TYPE 




2180 

C 




2190 

C ISEGR NEGATIVE MEANS USE NEXT AVAILABLE SEGMENT 




2200 

C ISEGW NEGATIVE MEANS USE NEXT AVAILABLE SEGMENT 




2210 

C (AFTER THE LAST ONE READ OR WRITTEN IN PREVIOUS CASE) 



2220 

C INITIAL DEFAULTS FOR NULL DATA ARE 0, 1. 




2230 

C INITIAL NEXT SEGMENTS ARE 0, 1. 




2240 

C 




2250 

ISEGR = 0 




2260 

ISEGW = 1 




2270 

c 




2280 

ISEGRN = 0 




2290 

ISEGWN = 1 




2300 

C 




2310 

C IBEGDA - FIRST DIRECT ACCESS OUTPUT STEP (-1 MEANS 

NSTEP ) 



2320 

C IINCDA - INCREMENT FOR DIRECT ACCESS OUTPUT STEP 
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2330 

2340 

2350 

2360 

2370 

2380 

2390 

2400 

2410 

2420 

2430 

2440 

2450 

2460 

2470 

2480 

2490 

2500 

2510 


C 

C 

C 

C 

C 

C 

C 

C 

C 


IBEGDA = -1 
IINCDA = 9900 

DIAGNOSTIC PRINTING INTERVAL. ZERO MEANS NSTEP/55 
NDIAG = 0 

PRINT AND CONTOUR CONTROL USES IPC(J,IAPC) 

NUMBER OF PRINTER LINES FOR CONTOUR PLOTS, PHYSICAL AND INTEGER. 
ZERO MEANS USE CODE DEFAULTS 

NCLP = 0 
NCLI = 0 


C 

C 

c 

c 


PLOT CONTROLS 

R STRETCH FACTOR FOR PLOTS 
Z BOTTOM AND TOP FOR PLOTS 


2520 

C 


(ZERO IMPLI1 

2530 

C 



2540 



RSTRPL = 

2550 



ZBPL = 

2560 



ZTPL = 

2570 

c 



2580 

c 

NUMBER OF PRI 

2590 

c 

NOT USED FOR 

2600 

c 



2610 



NCOPIES 

2620 

c 



2630 

c 

IPC( 16 , I APC ) 

2640 

c 



2650 

c 

J 

= 1 ISTEP 

2660 

c 

J 

= 2 ISTEP 

2670 

c 



2680 

c 

J 

= 3 ISTEP 

2690 

c 

J 

= 4 ISTEP 

2700 

c 



2710 

c 

J 

= 5 ISTEP 

2720 

c 

J 

= 6 ISTEP 

2730 

c 



2740 

c 



2750 

c 



2760 

c 



2770 

c 



2780 

c 

J 

=7,8,9 

2790 

c 

J 

= 10, 11, ] 

2800 

c 



2810 

c 

J 

= 13 I DAI C 

2820 

c 

J 

= 14 IDAK 

2830 

c 



2840 

c 

J 

= 15 IDAK 

2850 

c 

J 

= 16 IDAK 

2860 

c 



2870 

c 

ACONT .NE. 0 

2880 

c 

ACONT . EQ . 0 

2890 

c 

NCONT IS NOT 

?ann 

r 




AND ACONT(IAPC) CONTROL ARRAY OUTPUT. 

START FOR PRINTER CONTOUR AGAINST PHYSICAL VARIABLES 

INCREMENT FOR PRINTER CONTOUR AGAINST PHYSICAL VARIABLES 

START FOR PRINTER CONTOUR AGAINST INTEGER VARIABLES 

INCREMENT FOR PRINTER CONTOUR AGAINST INTEGER VARIABLES 

START FOR PRINTING NUMBERS 

INCREMENT FOR- PRINTING NUMBERS. 

NEGATIVE MEANS' WRITE THEM IN A FILE FOR LATER PLOTTING. 
J=7 SIGN NEGATIVE TO WRITE NEW PLOT FILE WITH HEADER. 

J=7 SIGN CORRECTED ONCE HEADER IS WRITTEN. 

J=7 SIGN POSITIVE - OPEN FILE AS 'OLD'. 

PRINT DO LOOP CONTROLS FOR I 
L2 PRINT DO LOOP CONTROLS FOR K 

0 START FOR PLOTTER CONTOUR AGAINST PHYSICAL VARIABLES 

0 INCREMENT FOR PLOTTER CONTOUR AGAINST PHYSICAL VARIABLES 

0 START FOR PLOTTER CONTOUR AGAINST INTEGER VARIABLES 

0 INCREMENT FOR PLOTTER CONTOUR AGAINST INTEGER VARIABLES 

MEANS USE ACONT FOR PLOTTER CONTOUR INCREMENT 
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2910 

C THIS 

LOOP TO NAPC COVERS ALL THE PLOT TYPES. 

2920 

C 


2930 


DO 100 IAPC = 1, NAPC 

2940 

C 


2950 


DO 110 J = 1, 16 

2960 

110 

I PC ( J , IAPC ) = J + 9900 

2970 

C 


2980 

C 


2990 


IPC( 7, IAPC) = 2 

3000 


IPC( 8, IAPC) = NRP1 

3010 


IPC( 9, IAPC) = 1 

3020 


I PC (10, IAPC ) = 2 

3030 


IPC (Ilf IAPC ) = NZP1 

3040 


IPC ( 12 , IAPC ) = 1 

3050 

C 


3060 


IF (IAPC .LE. 5) THEN 

3070 


IPC( 8, IAPC) = NRCPl 

3080 


I PC (11, IAPC ) = NZCPl 

3090 


ELSE IF (IAPC .LE. 11) THEN 

3100 


IPC (10, IAPC ) = 1 

3110 


I PC ( 1 1 , IAPC ) = 1 

3120 


ELSE IF (IAPC .GE. 14 .AND. IAPC .LE. 17) THEN 

3130 


IPC( 8, IAPC) = NRPl 

3140 


IPC ( 11 , IAPC ) = NZPl 

3150 


ENDIF 

3160 

C 


3170 


ACONT ( IAPC ) = 0. 

3180 

C 


3190 

100 

CONTINUE 

3200 

c 


3210 

c 

LONG AND SHORT CHARACTER 

3220 

c 


3230 


LTITLE ( 1 ) = 'MESH' 

3240 


LTITLE ( 2 ) = 'TEMPERATURE IN THE WHOLE SYSTEM' 

3250 


LTITLE ( 3 ) = 'CHANGE IN TEMPERATURE' 

3260 


LTITLE ( 4 ) = 'SPECIFIC HEAT ( cal/cc/deg ) ' 

3270 


LTITLE ( 5 ) = 'CONDUCTIVITY ( cal/cm sec deg)' 

3280 


LTITLE(6) = 'INTERFACE HEIGHT' 

3290 


LTITLE ( 7 ) = 'INTERFACE CHANGE' 

3300 


LTITLE ( 8 ) = 'INTERFACE TEMPERATURE' 

3310 


LTITLE ( 9 ) = ' INTERFACE* TEMPERATURE CHANGE' 

3320 


LTITLE (10) = 'MELT- CONCENTRATION AT THE INTERFACE' 

3330 


LTITLE (11) = 'CRYSTAL CONCENTRATION AT THE INTERFACE' 

3340 


LTITLE (12) = 'CONCENTRATION IN THE MELT' 

3350 


LTITLE (13) = 'CHANGE IN THE CONCENTRATION' 

3360 


LTITLE (14) = 'VORTICITY' 

3370 


LTITLE (15) = 'CHANGE IN THE VORTICITY' 

3380 


LTITLE (16) = 'STREAM FUNCTION' 

3390 


LTITLE (17) = 'CHANGE IN THE STREAM FUNCTION' 

3400 


LTITLE (18) = 'RELATIVE DENSITY EXCESS' 

3410 


LTITLE ( 19 ) = 'DIFFUSIVITY' 

3420 


LTITLE ( 20 ) = 'KINEMATIC VISCOSITY' 

3430 

c 


3440 


STITLE(l) = 'MESH' 

3450 


STITLE ( 2 ) = 'TEMP' 

3460 


STITLE ( 3 ) = 'DT' 

3470 


STITLE ( 4 ) = 'CP' 



STITLE(5) = 'COND' 
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3490 


STITLE ( 6 ) = 

f 

PINT' 

3500 


STI TLE ( 7 ) = 

t 

DFINT ' 

3510 


STITLE ( 8 ) = 

t 

TINT' 

3520 


STITLE ( 9 ) = 

t 

DTINT ' 

3530 


STITLE ( 10 ) 

= 

' CINTM ' 

3540 


STITLE ( 11 ) 

= 

' CINTC ' 

3550 


STITLE ( 12 ) 


' CONC ' 

3560 


STITLE ( 13 ) 

= 

' DCONC ' 

3570 


STITLE ( 14 ) 

= 

' VORT' 

3580 


STITLE ( 15 ) 

= 

' DVORT ' 

3590 


STITLE ( 16 ) 

=B 

' PSI ' 

3600 


STITLE ( 17 ) 

= 

'DPSI ' 

3610 


STITLE ( 18 ) 

= 

'BUOY' 

3620 


STITLE ( 19 ) 

= 

' DIFF' 

3630 


STITLE ( 20 ) 

= 

'VISC' 

3640 

C 




3650 


RETURN 



3660 


END 
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10 

20 

30 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 

210 

220 

230 

240 

250 

260 


C 

C 

C 


C 

C 

C 


CALL SCMBLP ( NRP2 , NRPl , RINS , RSAM, DRINS , DRSAM , 
1 RW , RH , DIDRW , DIDRH , DIDRMS ) ' 


C 

C 

c 


FLAG TO AVOID WRITING FIRST VALUES, AND TO SAVE WHOLE DERIVATIVE IN DX 


DIDRMA = 1757 
D I DRAB = DRAMPI 
IF ( NRA .GT. 0) 

1 CALL SCMBLP ( NRAP2 ,NRAPl , RSAM, RAMP , DIDRAB , DRAMPO , 

1 RW ( NRPl ) , RH ( NRPl ) ,DIDRW(NRPl) , DIDRH ( NRPl ) , DIDRMA) 


C 

C 

C 


WRITE MESH DIAGNOSTICS 


WRITE (6,5) ' RW ' , RW 

WRITE (6,5) ' RH ' ,RH 

WRITE (6,5) ' DIDRW ' , DIDRW 

WRITE (6,5) ' DIDRH ' , DIDRH 

FORMAT ( //IX , A, T12 , 1P10E11 . 3 , :/(Tl2,lPl0Ell.3, : ) 


270 

C 


280 

C 

HALF POINT ARRAYS 

290 

C 

FOR THE CRYSTAL, TVBTRH 

300 

C 


310 


DO 3 I = 1, NRCP2 

320 

C 


330 


RDRB2H(I) = RH ( I ) 

340 


RB2DRH ( I ) = RH ( I ) 

350 


RDRWQH ( I ) = RH ( I ) 

360 

C 


370 


IF (I .GT. NRPl) 

380 


TVBTRH ( I ) 

390 


ELSE 

400 


TVBTRH ( I ) 

410 


CVBTRH ( I ) 

420 


BTF(I) = 

430 


HBRDRH ( I ) 

440 


END IF 


450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


3 

C 

c 

c 


CONTINUE 


WHOLE POINT ARRAYS 


4 

C 


DO 4 I = 1, NRCPl 
RDRB2W(I) = RW ( I ) /DIDRW ( I ) /2 
RB2DRW(I) = RW ( I ) *DIDRW ( I )/2 
CONTINUE 


DO 6 I = 1 , NRPl 
R2W ( I ) = RW ( I ) * * 2 
R4W ( I ) = RW ( I ) * * 4 

DRB2RW ( I ) = .5 / DIDRW ( I ) / RW(I) 

UVBTRW ( I ) = RW ( I ) /DIDRW ( I ) / TAUU / ( DIDRMS/DI DRW ( I ) ) * * PRU 
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590 

6 

CONTINUE 

600 

C 


610 

C SET 

UP Z-MESH AND ARRAYS 

620 

C 


630 


CALL MESH 

640 

C 


650 


RETURN 

6568B 


END 


4 
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10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
22 0 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
520 
530 
540 
550 
560 
570 
580 


SUBROUTINE MESH 

C GET Z MESH AND INTERFACE ARRAYS AT NEW TIME. CALLED FROM INITl AND TFS 
C 

INCLUDE ' COM. /NOLIST' 

C 

C EQUIVALENCE FOR SCMBLP CALL 
C 

C DIMENSION ZESW( NZPl ) ,DKDZSW(NZPl ); 

C DIMENSION ZESH(NZP1 ) ,DKDZSH(NZP1 ) 

C EQUIVALENCE ( ZESW , ZETW ( NZPl )),( DKDZSW , DKDZTW ( NZPl ) ) 

C EQUIVALENCE ( ZESH , ZETH ( NZPl )),( DKDZSH , DKDZTH ( NZPl ) ) 

C 

c GET FMAX AND FMIN 
C 

FMAX = FINTH ( 2 ) 

FMIN = FINTH ( 2 ) 

DO 10 I = 3, NRP 1 

FMAX = MAX( FMAX, FINTH ( I ) ) 

10 FMIN = MIN( FMIN, FINTH( I ) ) 

C 

c SET ZL AND ZINT FOR THE COORDINATE TRANSFORMATION. 

C IF THEY CHANGE, THEN THE INPUT ZINTL AND ZINTI WERE WRONG. 

C IF THEY DON'T CHANGE, THEN ZETA AND ETA STAY FIXED. 

C THESE STATEMENTS CAN BE CHANGED TO REFORMULATE ZINT AND ZL CHOICE 
C 

C THESE THREE CONSTANTS MUST BE IN DECREASING ORDER 
C 

ZLl = 16 
ZL2 = 10 
ZL3 = 6 
C 

DFM = FMAX - FMIN 
ZLI = (RSAM-RINS) * ZINTL 
C 

ZL = MAX ( ZLI, DFM* ZL2 , MIN ( ZL , DFM*ZLl ) ) 

C 

ZINT = MIN( ZINT , FMIN+ZL/ZL3 ) 

ZINT = MAX(ZINT,FMAX-ZL/ZL3) 

c 

C SKIP ZETA AND ETA SET-UP IF "ZL AND ZINT WERE NOT CHANGED 

IF (ISTEP .GT. 0 .AND. ZL .EQ. ZLP .AND. ZINT . EQ . ZINTP) 

1 GO TO 80 

C 

C WRITE ONLY AT STEPS 0, 1, 2, 4, 8 , ... 

C 

IF (ISTEP .LE. 2) ISTEFN = ISTEP 
IF (ISTEP .EQ. ISTEPN) THEN 
ISTEPN = 2 * ISTEP 

WRITE (6,99) ISTEP, ZL, ZINT, FMAX, FMIN 
99 FORMAT ( / ' MESH. ISTEP = ' , 1 4 , 9X , ' ZL , ZINT, FMAX, FMIN - 

1 , 9F8 . 4 ) 

ENDIF 

C 

c SAVE PREVIOUS VALUES 
C 

ZLP = ZL 
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ZINTP = ZINT 
C 

C SET UP ZETA MESHES 
C 

CALL SCMBLP ( NZP2 ,NZPl , ZT, ZINT, -DZT, -DZINTM, 

1 ZETW , ZETH , DKDZTW , DKDZTH , DKDZMM ) 

C 

C FLAG TO AVOID WRITING FIRST VALUES, AND TO SAVE WHOLE DERIVATIVE IN DX 
C 

DKDZMC = 1757 
DKDZTC = -DZINTS 

CALL SCMBLP ( NZ SP2 , NZSPl , Z INT , ZB , DKDZTC DZB 

1 , ZETW( NZPl ) ,ZETH(NZPl) , DKDZTW ( NZPl ) , DKDZTH ( NZPl ), DKDZMC ) 

C i-i-' 

C SET UP ETA ARRAYS FOR Z MESH 
C Z = ZET + RF * ETA(ZET) 

C ETA = 1 AT INTERFACE 
C 0 AT TOP AND BOTTOM 

C SMALL EXCEPT NEAR INTERFACE 

C 

C HALF POINTS BELOW INTERFACE 
C 

DO 60 K = NZP2, NZCP2 

ETAH(K) = (ZETH(K) - ZB) / (ZINT - ZB) 

1 / (1. + ((ZINT - ZETH(K) )/ZL) ) 

60 DEDZTH(K) = ( 1 . / ( Z I NT - ZB) + ETAH ( K )/ZL ) 

1 / (1. + ((ZINT - ZETH(K) )/ZL) ) 

C 

C HALF POINTS ABOVE INTERFACE 
C 

DO 40 K = 1, NZPl 

ETAH(K) = (ZT - ZETH ( K ) ) / ( ZT - ZINT) 

1 / (1. + ( ( ZETH ( K ) - ZINT ) /ZL ) ) 

40 DEDZTH(K) = - ( 1 . / ( ZT - Z INT ) + ETAH ( K ) /ZL ) 

1 / (1. + ( ( ZETH ( K ) - ZINT )/ZL ) ) 

C 

C WHOLE POINTS BELOW INTERFACE 
C 

DO 70 K = NZPl, NZCP1 

ETAW(K) = (ZETW(K) - ZB) / (ZINT - ZB) 

1 / (1. + ((ZINT- ZETW(K) )/ZL) ) 

70 DEDZTW(K) = ( 1 . / ( ZINT - ZB) + ETAW(K)/ZL) 

1 / (1. + ((ZINT - ZETW(K) )/ZL) ) 

C 

C WHOLE POINTS ABOVE AND ON THE INTERFACE 
C 

DO 50 K = 1, NZPl 

ETAW(K) = (ZT - ZETW(K)) / ( ZT - ZINT) 

1 / (1. + ( ( ZETW ( K ) - ZINT )/ZL ) ) 

50 DEDZTW(K) = - ( 1 . / ( ZT - Z INT ) + ETAW(K)/ZL) 

1 / (1. + ( ( ZETW ( K ) - ZINT )/ZL ) ) 

C 

C CRYSTAL INTERFACE VALUE 
C 

DEDZTC = 1 . / ( Z INT - ZB ) + l./ZL 


C 

c ALL HALF POINTS 
C 


C-3L 
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72 

C 

C ALL 
C 


SET UP ARRAYS FOR THE VARIABLE TIME STEPS 


74 
C 
C 
C 

C MELT 
C 


DO 72 K = 1, NZCP2 
ETA2H ( K ) = ETAH ( K ) * * 2 
DZTDKH(K) « 1. / DKDZTH(K) 

DETDKH(K) = DEDZTH(K) * DZTDKH(K) 

WHOLE POINTS 

DO 74 K = 1, NZCP1 
ETA2W ( K ) = ETAW ( K ) * * 2 
DZTDKW(K) - 1. / DKDZTW(K) 
DETDKW(K) = DEDZTW(K) * DZTDKW(K) 


ORIGINAL PAGE IS 
OF POOR QUALITY 


15 

C 

C 

C 


DO 15 K = 
TVBTZH ( K ) 
UVBTZW ( K ) 
CVBTZH ( K ) 
CONTINUE 


2, NZPl 
= DZTDKH(K) 
= DZTDKW(K) 
= DZTDKH(K) 


( DKDZMM/DKDZTH ( K ) )**PZT 
( DKDZMM/DKDZTW ( K ) ) **PZU 
( DKDZMM/DKDZTH ( K ) ) **PZC 


CRYSTAL 


DO 25 K = 
TVBTZH ( K ) 
CONTINUE 


NZP2 , NZCPl 
= DZTDKH(K) 


* ( DKDZMC/DKDZTH ( K ) )**PZT 


25 
C 

C END ZETA AND ETA SETUP 
C 

80 CONTINUE 


1480 

c 


1490 

c 


1500 

C SET 

INTERFACE ARRAYS, STARTING FROM FINTH AND DFINTH 

1510 

c 


1520 

C SET 

AXIS VALUES USING SYMMETRY 

1530 

C 


1540 


FINTH ( 1 ) = FINTH ( 2 ) 

1550 


DFINTH ( 1 ) = DFINTH ( 2 ) 

1560 

C 


1570 

C SET 

FAMP AND DFAMP USING EXTRAPOLATION, SEE BLKDAT . 

1580 

C 


1590 


FAMP = 0 

1600 


DFAMP = 0 

1610 


DO 19 J = 1, 3 

1620 


FAMP = FAMP + FINTH ( NRP2 - J ) * FABC ( J ) 

1630 

19 

DFAMP = DFAMP + DFINTH ( NRP2 - J ) * FABC(J) 

1640 

C 


1650 

C SET 

RFINT ARRAYS AT HALF AND WHOLE POINTS IN SAMPLE 

1660 

C 


1670 


DO 20 I * 1, NRPl 

1680 

20 

RFINTH ( I ) = FINTH ( I ) - ZINT 

1690 

C 


1700 


DO 30 I = 1, NR 

1710 


DFINTW ( I ) = ( DFINTH ( I ) + DFINTH(I + 1) ) / 2. 

1720 

30 

RFINTW ( I ) = ( RFINTH ( I ) + RFINTH(I+1) ) / 2. 

1730 

C 

< 

i -i a n 

r- CTT 

T3FTMT AND DFINT ARRAYS AT HALF AND WHOLE POINTS 


FROM 2 TO NRPl 


IN AMPOULE 
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1750 

C 


1760 


DO 22 I = NRP2, NRCP2 

1770 


DFINTH(I) = DFAMP 

1780 

22 

RFINTH(I) = FAMP - ZINT 

1790 

C 


1800 


DO 32 I = NRPl , NRCPl 

1810 


DFINTW ( I ) = DFAMP 

1820 

32 

RFINTW(I) = FAMP - ZINT 

1830 

C 


1840 

C SET ARRAYS FOR DFDR AND MULTIPLES 

1850 

C SINCE DFDR MAY BE SMOOTHER THAN DFDI (DUE 

1860 

C WE 

EXTRAPOLATE DFDR NEAR THE BOUNDARY. 

1870 

C 


1880 


DO 33 I - 1, NR 

1890 

33 

DFDRW(I) = DIDRW(I) * (FINTH(I+1) - 

1900 


DFDRW ( NRPl ) = 2 * DFDRW(NR) - DFDRW( 

1910 

C 


1920 


DO 34 I = 1, NRPl 

1930 


DFDR = DFDRW ( I ) 

1940 


RDRF8W ( I ) = RW ( I ) * DFDR / 8. 

1950 


DRF8RW ( I ) = DFDR / 8. / RW ( I ) 

1960 

34 

ZDRFW(I) = DFDR*DFDR * DRB2RW(I) 

1970 

C 


1980 


DO 35 I = 2, NRPl 

1990 


DFDR = ( DFDRW ( I ) + DFDRW(I-l)) * .5 

2000 


RDRF8H ( I ) = RH(I) * DFDR / 8 

2010 


DRF8RH(I) = DFDR / 8. / RH ( I ) 

2020 

35 

ZDRFH(I) = DFDR*DFDR * RDRB2H(I) 

2030 

C 


2040 

C Z 

ARRAYS IN AMPOULE 

2050 

C 


2060 


DO 81 K * 1, NZCP2 

2070 


ZAH(K) = ZETH(K) + ( FAMP - Z INT ) *ETAH 

2080 


DKDZAH(K) = DKDZTH ( K ) / ( 1 . + (FAMP-Z: 

2090 

81 

DZDKAH(K) = 1 . /DKDZAH ( K ) 

2100 

C 


2110 


DO 82 K = 1, NZCPl 

2120 


ZAW(K) = ZETW(K) + ( FAMP - Z INT ) *ETAW 

2130 


DKDZAW(K) = DKDZTW ( K)/( 1 . + (FAMP-Z 

2140 

82 

DZDKAW(K) = 1 . /DKDZAW ( K ) 

2150 

C 


2160 

C CORRECT MIDDLE TERM 

2170 

C 


2180 


DZDKAW ( NZPl ) = 0.5 * ( DZDKAH(NZPl) 

2190 


1 + (1 + ( FAMP - ZINT ) *DEDZTC ) 

2200 


DKDZAW ( NZPl ) = 1 . /D Z D K AW (NZPl) 

2210 

C 


2220 

C WRITE ONE - DIMENSIONAL MESH DIAGNOSTICS 

2230 

C 


2240 


IF (ISTEP .EQ. 0) THEN 


TO THE NON-UNIFORM MESH) 


/ DKDZTC ) 


2250 

2260 

2270 

2280 

2290 

2300 

2310 

2320 


WRITE (6,5) ' ZETW' , ZETW 
WRITE (6,5) ' ZETH ' , ZETH 
WRITE (6,5) 'DKDZTW' ,DKDZTW 
WRITE (6,5) 'DKDZTH' ,DKDZTH 
WRITE (6,5) ' ETAW' , ETAW 
WRITE (6,5) ' ETAH ' , ETAH 
WRITE (6,5) .'DEDZTW' ,DEDZTW 
WRITE (6,5) 'DEDZTH' , DEDZTH 
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2330 

2340 

2350 

2360 

2370 

2380 

2390 

2400 

2410 

2420 

2430 

2440 

2450 

2460 


5 


FORMAT ( //lX, A, T12 , 1P10E11 .3, :/(Tl2,lPlOEll.3 

ENDIF 


C 

C MESH DIAGNOSTICS 
C 


c 

c 

c 


CALL MDIAG 

CALL PRNT ( ZHH,NRCP2 ,1 ) 

CALL PRNT ( FINTH , NRP2 , 6 ) 

IF (ISTEP .GT. 0) CALL PRNT ( DFINTH , NRP2 , 7 ) 


ZHH ABOVE IS A DUMMY ARGUMENT, NOT USED BY PRNT. 


RETURN 

END 


:)) 


ORIGINAL PAGE S3 
OF POOR QUALITY 
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SUBROUTINE INIT2 

20 

C 


30 

C INIT2 

INITIALIZES THE ARRAYS AND MESH, 

40 

C 

USING ANALYTIC FORMS OR DIRECT ACCESS INPUT, 

50 

C 

CALLS PRNT FOR THE INITIAL ARRAYS, AND 

60 

C 

CALLS SMATPR , SINTPR, MESH, WHICH CALL PRNT. 

70 

C 


80 

C CALLED 

FROM MAIN, FOR INITIALIZATION 

90 

C ALSO CALLED FROM CMAIN , VIA CONT, TO DO 'PLOTS . 

100 

C 


110 

C SNREC 

SETS UP THE DIRECT ACCESS READ AND WRITE 

120 

C DDAOUT DOES THE DIRECT ACCESS OUTPUT 

130 

C 


140 


INCLUDE ' COM . /NOLIST ' 

150 

c 


160 


CHARACTER JTDES(72) 

170 

c 


180 

C ZHH FROM STATEMENT FUNCTION 

190 

C 


200 


ZHH ( I , K ) = ZETH(K) + ETAH(K) * RFINTH ( I ) 

210 

C 


220 

C SEt ISTEF AND LOGICAL D I AG . 

230 

c 


240 


ISTEP = 0 

250 


DIAG = .TRUE. 

260 

c 


270 


IF ( ISEGR .EQ. 0 ) THEN 

280 


TTIME =0. 

290 

c 


300 

c 

GET TMELT AND CMELT FROM CCRYS=CTOP 

310 

c 


320 


CALL GTMCM ( TMELT , CMELT , CTOP ) 

330 


CINSC = PRPMAT (1,11) / WAMP 

340 


WRITE ( 6 , ' ( ' INIT2. ", 

350 


1 "TMELT, CMELT, CINSC = " , 2F8 . 2 , Fl 0 . 5/ ) ' ) 

360 


1 TMELT, CMELT, CINSC 

37 0 


FF = ZTBOT + ( ZTTOP - ZTBOT ) 

380 


1 / ( 1 . +PRPMAT ( 1 , 4 ) * ( TTOP - TMELT ) /PRPMAT ( 1 , 5 ) /( TMELT - TBOT ) ) 

1 390 

c 


1 4 00 


ZL = (RSAM-RINS) * ZINTL 

3 410 


IF (ZINTI .EQ.' 0) THEN 

| 420 


ZINT = FF 

! 430 


ELSE 

440 


ZINT = ZINTI 

450 


ENDIF 

460 

c 


470 


DO 2 I = 1, NRP2 

480 


TINTH(I) = TMELT 

490 


CINTMH ( I ) = CMELT 

500 


CINTCH ( I ) = CTOP 

510 


DFINTH ( I ) = 0 

520 


QR = 1 - . 1*(1 - ( (1-1.5) /NR)* *2) 

530 

2 

FINTH(I) = FF * QR 

540 

C 


550 


CALL INITl 

560 

C 


570 

C MELT 

TEMPERATURE * ; 

580 


DO 11 K = 1, NZ Pi 
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DO 11 I = 1, NRP 1 

TT = TTOP - ( ZTTOP - ZHH ( I , K ) ) /( ZTTOP - FI NTH ( I ) ) 

1 * ( TTOP - TINTH ( I ) ) 

TT = MAX ( TT , TBOT ) 

TT = MIN ( TT , TTOP ) 

11 T ( I , K ) = TT 

C CRYSTAL TEMPERATURE 

DO 12 K = NZP2, NZCP2 
DO 12 I = 1, NRPl 

TT = TBOT + ( ZHH ( I , K ) - ZTBOT )/ ( FI NTH ( I ) - ZTBOT ) 

1 * (TINTH(I) -TBOT) 

TT = MAX ( TT , TBOT ) 

TT = MIN ( TT , TTOP ) 

12 T ( I , K ) = TT 
C AMPOULE TEMPERATURE 

DO 13 K = 1, NZCP2 
DO 13 I = NRP2, NRCP2 

TT = TBOT + ( ZHH ( I , K ) - ZTBOT ) / ( ZTTOP - ZTBOT ) * (TTOP 

TT = MAX ( TT , TBOT ) 

TT = MIN ( TT , TTOP ) 

13 t ( I , K ) = TT + ( T ( NRPl , K ) - TT ) * (RAMP - RH(I)) / 

C CONCENTRATION 

DO 3 I = 1, NRPl 
DO 3 K = 1 , NZP2 

3 cTl,K) = CTOP + (CMELT-CTOP) 

1 * ( EXP ( ( FINTH ( I ) - ZHH (I,K))/CINSC) 

1 - EXP ( ( FINTH (I ) -ZT)/CINSC) ) 

1 /(I - EXP ( ( FINTH ( I ) - ZT )/CINSC ) ) 

C STREAM FUNCTION 

CALL SETPSI 


C 


ELSE 

CALL DAOPN ( NR ,21) 

CALL DAOPN ( NRC , 22 ) 

IRECl = IREC1R 
IREC2 = IREC2R 

CALL DAINP(FINTH(1-NRP2) , 1 , 1 , NRP2 , 3 , 1 , 21 , IRECl ) 
CALL DAINP ( DFINTH ( 1 -NRP2 ) , 1 , 1 ,NRP2 ,3,1,21, IRECl ) 
CALL DAINP ( TINTH (1-NRP2) , 1 , 1 , NRP2 , 3 , 1 , 21 , IRECl ) 
CALL DAINP ( CINTMH ( 1 - NRP 2 ) , 1 , 1 ,NRP2 ,3,1,21, IRECl ) 
CALL DAINP (CINTCH(1-NRP2) , 1 , 1 , NRP2 , 3 , 1 , 21 , IRECl ) 
CALL DAINP ( C, 1 , 1 ,NRP2 ,NZP2 ,1,21, IRECl ) 

CALL DAINP ( PSI , 1 , 1 ,NRP2 ,NZP2 ,1,21, IRECl ) 


CALL DAINP ( T, 1 , 1 , NRCP2 ,NZCP2 , 1 , 22 , IREC2 ) 


C 

C 

C 


10 


READ SEGMENT DESCRIPTOR FROM SINGLE RECORD 
LJT = MIN ( 72 , NCPRN* ( NRC - 3 ) ) 

READ ( 22 ,REC=IREC2 ) TTIME , ZL , ZINT , ( JTDES ( I ) , 1=1 , 

WRITE (6,10) ISEGR, TTIME , ZL , ZINT , ( JTDES ( I ) , 1=1 > 

FORMAT (/' INIT2. ISEGR, TTIME =',I6,F14.3/ 
i T8 , ' ZL , ZINT =' , 2F10 . 5/10X,72Al ) 


C 

CLOSE ( 21 , DISP= ' KEEP' ) 
CLOSE (22,DISP='KEEP f ) 
C 


-TBOT) 

(RAMP 


LJT) 

LJT) 


CALL INITl 
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C 

C 

C 


ENDIF 

APPLY BOUNDARY CONDITIONS 

CALL TBC 
CALL CBC 
CALL PSIBC 


C 

c 

c 


DIAGNOSTICS FOR INITIAL CONDITIONS AND FOR WHEN 

CALL PRNT ( T ,NRCP2 , 2 ) 

CALL TDIAG 


IF (LC) 

THEN 


CALL 

PRNT ( C ,NRP2 , 12 ) 


CALL 

CDIAG 

ENDIF 

IF (LU) 

THEN 


CALL 

PRNT ( PSI ,NRP2, 16 ) 


CALL 

PDIAG 


CALL 

GVORT 


CALL 

PRNT ( VORT,NRPl , 14 ) 


CALL 

VDI AG 

ELSE 


CALL 

PRNT (PSI ,NRP2,16) 

ENDIF 

CALL SINTPR 


CALL SMATPR 



C 

C 

C 


C 

C 


DO A SINGLE STEP TO PLOT CHANGES IF REQUIRED 
IF ( LCONT ) THEN 

IF ( PRTEST ( 3 ) .OR. ( LC .AND, 
IDAIOS = IDAIO 
IDAI0 = -1 
IPC ( 1 3 , 3 ) = -1 

IPC ( 1 3 , 1 3 ) = -1 

ISTEP = 1 
CALL TFSTEP 
IDAIO = IDAIOS 

ENDIF 

IF (LU .AND. ( PRTEST (15) .OR. 

ENDIF 


RETURN 

END 


INIT2 IS CALLED FROM C 


PRTEST ( 13)) ) THEN 


PRTEST( 17 ) ) CALL USTEP 
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SUBROUTINE SNREC 
C 

C DIRECT ACCESS READ AND WRITE SEGMENTS 

C FOR FIRST CASE THE 'NEW' VALUES ARE SET IN SETUP AS 0, 1. 

C LATER THEY ARE SET BY DAREC. __ TXT -, TM 

C ISEGRU AND ISEGWU ARE USED. ISEGR AND ISEGW ARE LEFT FOR LATER PRINTIN 

C 

C PRINT DIRECT ACCESS RECORD RANGE INFORMATION 
C GET ISEGRN, ISEGWN. 

C GET ISEGRU, ISEGWU. 

C GET IRECR , IRECW , FOR BOTH DIRECT ACCESS FILES. 

C 

INCLUDE ' COM. /NOLIST' 

C 

CALL DAREC ('READ ' , I SEGR , I SEGRN , 1 , 1 , ISEGRU ) 

NOUT = MAX (0,(NSTEP- IDAOUT+I INCDA ) /I INCDA ) 

CALL DAREC ( 'WRITE' , I SEGW , I SEGWN , NOUT , 1 , I SEGWU ) 

C 

C SET NREC1 AND NREC2 TO MATCH THE DAINP AND DAOUT CALLS 
C 

NREC1 = 3 

NREC1 = NRECl + 2 + NZ 
NREC1 = NRECl + NZ 
NREC2 — NZC + 1 
C 

IREClR = 1 + (ISEGRU - 1) * NRECl 

IREClW = 1 + (ISEGWU - 1) * NRECl 

IREC2R = 1 + (ISEGRU - 1) * NREC2 

IREC2W = 1 + (ISEGWU - 1) * NREC2 

C 

RETURN 

END 


I 
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SUBROUTINE DDAOUT 
C 

C DO DIRECT ACCESS OUTPUT 
C CALLED FROM TFSTEP 

C PLACED HERE TO SIMPLIFY CHANGES IN THE STRUCTURE 
C 

INCLUDE 'COM. /NOLIST' 

C 

I = I STEP - IDAOUT 
J = I/IINCDA 

IF (I .LT. 0 .OR. J* I INCDA .NE. I) RETURN 
I SEG = ISEGW + J 
C 

WRITE (*,311) I STEP , ICASE , ISEG 
WRITE (6,311) ISTEP, ICASE, ISEG 
311 FORMAT (/' STARTING DAOUT AT STEP',16,' OF CASE',12 

1 SEGMENT' ,13/) 

C 

IRECl = IREClW + J * NREC1 
IREC2 = IREC2W + J * NREC2 
C 

CALL DAOPN(NR,21) 

CALL DAOPN ( NRC ,22) 

C 

CALL DAOUT ( FINTH( 1 -NRP2 ) , 1 , 1 ,NRP2, 3 , 1 , 21 , IRECl ) 

CALL DAOUT( DFINTH( 1 -NRP2 ) , 1 , 1 ,NRP2 ,3,1,21, IRECl ) 

CALL DAOUT ( TINTH( 1 -NRP2 ) , 1 , 1 ,NRP2 , 3 , 1 , 21 , IRECl ) 

CALL DAOUT ( CINTMH( 1 -NRP2 ) , 1 , 1 , NRP2 , 3 , 1 , 21 , IRECl ) 

CALL DAOUT(CINTCH(l-NRP2) , 1 , 1 , NRP2 , 3 , 1 , 21 , IRECl ) 

CALL DAOUT ( C ,1,1 ,NRP2 ,NZP2 ,1,21, IRECl ) 

CALL DAOUT ( PSI , 1 , 1 , NRP2 , NZP2 , 1 , 21 , IRECl ) 

C 

CALL DAOUT ( T , 1 , 1 ,NRCP2 ,NZCP2,1,22, IREC2 ) 

C 

LJTIM = MIN ( 28 , NCPRN* ( NRC - 4 ) ) 

LDESC = MIN( 44 , NCPRN* (NRC- 4 ) - 28 ) 

C 

C WRITE SEGMENT DESCRIPTOR TO SINGLE RECORD 
C 

LJTIM = MAX(MIN( 28 , NCPRN* ( NRC - 4 ) ) ,1 ) 

LDESC = MAX ( MIN (44, NCPRN* ( NRC - 4 ) - 28 ) , 1 ) 

WRITE (22,REC=IREC2) TTIME , ZL , ZINT , JTIME ( 1 : LJTIM) ,DESCR( 1 : LDESC ) 
C 

CLOSE ( 21 ,DISP=' KEEP' ) 

CLOSE (22,DISP='KEEP' ) 

C 

RETURN 

END 
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10 BLOCK DATA BLKDT 

20 C 

30 INCLUDE ' COM. /NOLI ST' 

40 C 

50 DATA PI /3 . 141592654/ 

60 DATA FABC /1 . 8 7 5 , - 1 . 2 5 , 0 . 37 5/ 

7 0 C DATA FABC /I . 5 , - 0 . 5 , 0 ./ 

80 C DATA FABC /l.,0.,0./ 

90 END 
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200 

210 

220 
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240 

250 

260 

270 

280 

65390 


PROGRAM CMAIN 


C 

C MAIN PROGRAM TO CALL CONT FOR POST - PROCESSING . 

C THE DATA FILE SHOULD BE CHANGED TO GET DIFFERENT PLOTS 
C 


C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


INCLUDE ' COM. /NOLIST' 

LCONT IS TRUE FOR THIS PROGRAM. 

LCONT = .TRUE. 

CALL SETUP 

CASE DO LOOP TERMINATES IN INI TO WHEN DATA RUNS OUT 
DO 20 ICASE = 1, 100 
INPUT SEGMENT 

CALL INIT0 


CALL LINEPL 
CALL CONT 
C 

20 CONTINUE 

C 

CALL STOPP ('CMAIN. TOO MANY CASES% ' ) 
END 
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20 
30 
40 
50 
60 
70 
80 
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140 
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190 
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230 
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260 
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320 
330 
340 
350 
360 
370 
380 
6 599 B 


SUBROUTINE CONT 
C 

C CONTOUR PLOT OUTPUT 
C 

INCLUDE ' COM . /NOLIST' 

C 

C I DAI O LOOP 
C 

NOUT = ( NSTEP + IINCDA - IDAOUT) / IINCDA 
C 

C LOOP FOR I DAI O 
C 

DO 100 IDAIO = 0, NOUT 

C ■ 

C FIND WHETHER DIRECT ACCESS READ IS REQUIRED 

C 

DO 10 IAPC = 1, NAPC 
L - 13 

J = IDAIO - I PC ( L , IAPC ) 

K = I PC ( L+ 1 , IAPC ) 

IF ( ( J /K ) *K . EQ. J .AND. J .GE. 0) GO TO 11 

10 CONTINUE 
GO TO 100 

11 CONTINUE 
C 

C GET RECORD FOR INIT2 AND MAKE CALL AS WITH RESTART. 
C IT CALLS PRNT , WHICH CALLS CPR. 

C 

IREC1R = IREClW + ( I DAI O - 1 ) * NRECl 

IREC2R = IREC2W + (IDAIO-1) * NREC2 

ISEGR = ISEGW + (IDAIO-1) * 1 
IF (IDAIO .EQ. 0) ISEGR = 0 
C 

CALL INIT2 
C 

100 CONTINUE 

C 

RETURN 

END 
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SUBROUTINE CPR ( VAR , ND , NCZ , IAPC , NCONT 
1 , NHHI , RPLL , RPLR , ZPLB , ZPLT ) 

C 

C CONTOUR PLOT OUTPUT. CALLED FROM PRNT . 

C 

INCLUDE 'COM. /NOLIST' 

C 

PARAMETER ( MXMYMAX = 4 * NRC * NZCP2 ) 

PARAMETER ( MXMAX = 4 * NRC ) 

COMMON W2 (MXMYMAX) ,W3( 4 , MXMAX) 

C 

DIMENSION VAR ( 1 ) 

DIMENSION RINT(l) 

EQUIVALENCE ( RINT , A ) 

C PLOT MESH FOR IAPC = 1, UNDER PHYSICAL CONTOUR PARAMETERS CONTROL 
C 

IF (IAPC .EQ. 1) THEN 

J = IDAIO - IPC ( 1 3 , IAPC ) 

K = IPC (14, IAPC ) 

IF ((J/K)*K .EQ. J .AND. J . GE . 0) 

1 CALL MESHPL ( RPLL . RPLR , ZPLB , ZPLT ) 

RETURN 

ENDIF 

C 

C SPECIAL TREATMENT OF ONE - DIMENSIONAL PLOTS 


270 

C 


280 


IF (NCZ .LE. 1) RETURN 

290 

C 

ZERO CONTOUR TO BE PLOTTED? NOT IF 

300 

C IS 

310 

C 


320 


AC = ACONT ( IAPC ) 

330 

C 


340 

C CONTOUR AGAINST PHYSICAL VARIABLES * 

350 

c 


360 


J = IDAIO - IPC ( 13 , IAPC ) 

370 


K = I PC ( 1 4 , IAPC ) 

380 


IF ( ((J/K)*K .NE. J) .OR. (J •' 

390 


CALL CPL ( VAR, ND, NCZ, IAPC, NCONT 

400 


1 , NHHI , RPLL, RPLR 

410 

20 

CONTINUE 

420 

C 


430 

C CONTOUR AGAINST INTEGERS 

440 

C 


450 


IPHYSICAL = 2 

460 


J = IDAIO - IPC (15, IAPC ) 

470 


K = IPC ( 16 , IAPC ) 

480 


IF ( ((J/K)*K .NE. J) .OK. (J . 

490 

c 


500 


N = MAX0 ( NCZ , ND ) 

510 


DO 30 I = 1, N 

520 

30 

RINT ( I ) = I 

530 

C 


540 


XT = ND 

550 


YT = NCZ 

560 

C 


570 


MX = ND 

580 


MY = NCZ 
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670 40 

680 C 
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65500 


IF ( MX* MY . GT . MXMYMAX .OR. MX.GT.MXMAX) 

1 CALL STOPP ('CPR DIMENSION%') 

CALL CONPL ( VAR , RINT , RINT , ND ,NCZ 

1 , IPHYSICAL,NCONT,AC,IAPC,TTIME 

1 ,1. ,XT ,1.,YT 

1 , W2 , MX , MY , W3 

1 , LTITLE ( IAPC ) , DESCR, MZW ,1,1) 

CONTINUE 

RETURN 

END 


ORIGINAL PAGE \Z 
OF POOR QUALITY 
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280 

290 
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320 

330 

340 
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360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


SUBROUTINE CPL ( VAR , MX , MY , IAPC ,NCONT , AC 
1 , NHHI , RPLL , RPLR , ZPLB , ZPLT ) 

C 

C CONTOUR PLOT ON THE TEKTRONIX IN WORLD SPACE 
C 

INCLUDE ' COM. /NOLIST' 

C 

C CONTVL IS AN ARRAY OF VALUES AT WHICH THE CONTOURS WILL BE PLOTTED 
C NCONT IS APPROXIMATE NUMBER OF CONTOURS DESIRED, IF ACONT IS ZERO. 
C 

DIMENSION VAR ( MX , MY ) 

PARAMETER ( MCONTN = 30) 

DIMENSION CONTVL (MCONTN) 

CHARACTER *40 BLANK 
DATA BLANK /' '/ 

C 

C STATEMENT FUNCTION TO GET V AT WW POINTS FROM V AT HH POINTS 
C 

V ( I , K ) = ( VAR ( I , K ) +VAR ( I , K+NHHI ) 

1 +VAR ( I +NHHI , K ) +VAR ( I+NHHI , K+NHHI ) ) * 0.25 

C 

C ZWW AND DZDKWH FROM STATEMENT FUNCTIONS 
C 


c 

C GET 
C 


3 

C 

C GET 
C 


ZWW ( I , K ) = ZETW(K) + ETAW(K) * RFINTW(I) 

DZDKWH ( I , K ) = DZTDKH(K) + DETDKH(K) * RFINTW ( I ) 

MAXIMUM AND MINIMUM 


VMAX = V ( 1 , 1 ) 

VMIN = V(l,l) 

DO 3 K = 1, MY - NHHI 
DO 3 I = 1, MX - NHHI 
VMAX = MAX ( V ( I , K ) , VMAX ) 
VMIN = MIN ( V ( I , K ) , VMIN ) 

IF (VMAX .EQ. VMIN) RETURN 

CONTOUR LEVELS 


IF (AC 

ELSE 

ENDIF 


.EQ. 0 .OR. AC .EQ. -1) THEN 
VINC = ROUND ( (VMAX -VMIN) /NCONT) 

VINC = ABS(AC) 


C 

C GET MIN AND MAX CONTOUR LEVELS 

C DON'T PLOT ZERO CONTOUR IF EXTREMUM IS CLOSE, SINCE 
C THE VALUES ARE PROBABLY SPURIOUS. THE CLOSENESS 
C CRITERION IS EPS, WHICH CAN BE CHANGED AT WILL. 

C VALUES BETWEEN ZERO AND 0.2 ARE APPROPRIATE. 

C 

EPS = 0.1 


c 

VR = VMIN/VINC 
ICMIN = VR + 4000. 

ICMIN = ICMIN - 4000 + 1 

IF (VR .LE. 0 .AND. VR .GT. -EPS) ICMIN = 1 
C 


VR = VMAX/VINC 
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590 
600 
610 
620 
630 
640 
650 
660 
670 
680 
690 
700 
710 
720 
730 
740 
I 750 

4 760 

770 
780 
790 
800 
810 
820 
830 
840 
850 
860 
870 
880 
890 
900 
910 
920 
930 
940 
950 
960 
970 
98 0 
1 990 

1000 
>4 1010 

1020 
1030 
1040 
1050 
1060 
1070 
1080 
1090 
1100 
1110 
1120 
1130 
1140 
1150 
i i fin 


ICMAX = VR + 4000. 

ICMAX = ICMAX - 4000 

IF (VR .GE. 0 .AND. VR .LT. EPS) ICMAX = -1 
C 

C DON'T PLOT FUNCTIONS WHICH ARE APPROXIMATELY CONSTANT, 

C BUT WRITE THE TEXT. 

C 

I CM IN = MAX (I CM IN, -3000) 

ICMAX = MIN (ICMAX, +3000) 

C 

C GET THE CONTOUR LEVELS ARRAY 
C 

NCONTN = ICMAX - ICMIN + 1 
IF (NCONTN .GT. MCONTN ) THEN 

WRITE (6,*)' CPL . NCONTN REDUCED FROM' 

1 , NCONTN, 'TO MCONTN = ' , MCONTN 

NCONTN = MCONTN 

ENDIF 

DO 2 I = 1, NCONTN 

2 CONTVL(I) = VINC * (I - 1 + ICMIN) 

C 

C CLEAR SCREEN 

C GET TERMINAL WINDOW AND RATIO 
C 

CALL INTERM 

CALL SEETW ( MINX , MAXX , MINY , MAXY ) 

MB = MAXX / 50 

MINX = MINX + MB 

MINY = MINY + MB 

MAXX = MAXX - MB 

MAXY = MAXY - MAX ( MB , MAXX/2 0 ) 

C 

XR = MAXX - MINX 
YR = MAXY - MINY 
C 

C GET NUMBER OF LINES OF TEXT AND RASTER EQUIVALENT 
C GET MAXIMUM NUMBER OF CHARACTERS AND RASTER EQUIVALENT 

C 

NLT = 6 

IF ( TTIME .NE. 0) NLT = NLT + 1 
RNLT = NLT * YR / NLPP 
C 

LD = LENGTH ( DESCR ,44) 

LT = LENGTH ( LTI TLE ( IAPC ) , 42 ) 

MNC = MAX (24, LD , LT ) + 6 
RMNC = MNC * XR / NCPL 
C 

C GET RECTANGLE HEIGHT, WIDTH, AND RATIO 
C 

HR = ZPLT - ZPLB 
WR = ( RPLR - RPLL ) * RSTRPL 
HOW = HR / WR 
C 

C GET SCALE WITH TEXT AT LEFT 
C 

SCALEL = MAX ( HR/YR , WR/ ( XR - RMNC ) ) 

C 

C GET SCALE WITH TEXT AT BOTTOM 


MIPS4$DRA3: [ ROBERTS . BS ] PCON . ;1 


18 - SEP - 1986 19:44 


Page 7 


1170 

C 


1180 


SCALEB = MAX ( HR/ ( YR - RNLT ) , WR/XR ) 

1190 


SCALE = MIN ( SCALEB , SCALEL ) 

1200 

c 


1210 

C PLACE 

TEXT AND TERMINAL WINDOW FOR LEFT 

1220 

C 


1230 


IF (SCALEL .LT. SCALEB) THEN 

1240 

C 


1250 


NBL = ( NLPP - NLT ) / 2 ; 

1260 

C 


1270 


NBC = 1 + NBCPL 

1280 

c 


1290 


MINX = MINX + RMNC 

1300 


MINY = MINY + ( YR/2 ) * MAX ( 0 . , 1 . - HOW/ ( YR/ ( XR - RMNC ) ) ) 

1310 

c 


1320 

C PLACE 

TEXT AND TERMINAL WINDOW FOR BOTTOM 

1330 

C 


1340 


ELSE 

1350 

C 


1360 


NBL = NLPP - NLT 

1370 


NBC = 1 + NBCPL + ( NCPL - MNC ) / 2 

1380 

C 


1390 


MINY = MINY + RNLT 

1400 


MINX = MINX + (RX/2) * MAX ( 0 . , 1 . - ( ( YR - RNLT ) /XR ) /HOW ) 

1410 

c 


1420 


ENDIF 

1430 

c 


1440 

C GET THE OPPOSITE CORNER OF THE WINDOW 

1450 

C 


1460 


MAXX = MINX + WR / SCALE 

1470 


MAXY = MINY + HR / SCALE 

1480 

c 


1490 

C TEXT 

ON PLOT 

1500 

C 


1510 


DO 120 IBL = 1, NBL-NLPA 

1520 

120 

WRITE (1,130) 

1530 

130 

FORMAT (IX) 

1540 


WRITE ( 1,140) BLANK (1:NBC) , LTI TLE ( IAPC ) ( 1 : LT ) 

1550 


WRITE ( 1 , 140 ) BLANK ( 1 :NBC ) , DESCR ( 1 : LD ) 

1560 

140 

FORMAT (A, A) 

1570 


WRITE (1,150) BLANK ( 1 : NBC ) , VMAX 

1580 


WRITE (1,160) BLANK ( 1 :NBC ) , VMIN 

1590 


WRITE (1,170) BLANK ( 1 :NBC ) , VINC 

1600 


IF ( TTIME .NE. 0) WRITE ( 1 , 18 0 ) BLANK ( 1 : NBC ), TTIME 

1610 

150 

FORMAT ( A , ' MAXIMUM =',1PG13.5) 

1620 

160 

FORMAT ( A , ' MINIMUM =',1PG13.5) 

1630 

170 

FORMAT ( A ,' INCREMENT =',1PG13.5) 

1640 

180 

FORMAT (A, ' TIME = ' , 1PG1 3 . 5 ) 

1650 

C 


1660 

C SET PLOT WINDOW AND TRANSFORM 

1670 

C 


1680 


EPSW = .02 

1690 

c 


1700 


RPWL = RPLL - EPSW * WR / RSTRPL 

1710 


RPWR = RPLR + EPSW * WR / RSTRPL 

1720 


ZPWB = ZPLB - EPSW * HR 

1730 


ZPWT = ZPLT + EPSW * , HR 

1740 

c 



MI PS 4 $DRA3 : [ ROBERTS . BS ] PCON . ; 1 


18 -SEP-1986 19:44 


Page 8 


1750 


CALL DWINDO(RPWL,RPWR,ZPWB,ZPWT) 

1760 

C 


1770 


CALL TWINDO ( MINX , MAXX , MINY , MAXY ) 

1780 

C 


1790 

C 


1800 

C DRAW 

BOUNDARY, INTERFACE, AND AMPOULE. 

1810 

C 


1820 


IF ( IMACH .NE. 2) CALL CZAXIS(l) 

1830 


RTICK - .05 * (RAMP - RINS) 

1840 

C 


1850 


DO 190 K = 1, NZCPl , NZC 

1860 


CALL MOVEA ( RW ( 1 ) , ZWW ( 1 , K ) ) 

1870 


I = NRCPl 

1880 

190 

CALL DASHA ( RW ( I ) , ZWW ( I , K ) , 12 ) 

1890 

C 


1900 


CALL MOVEA ( RW ( 1 ) , ZWW ( 1 , NZPl ) ) 

1910 


DO 192 1=2, NRPl 

1920 

192 

CALL DASHA ( RW ( I ) , ZWW (I, NZPl) ,31) 

1930 

C 


1940 


DO 195 I = NRPl, NRCPl, NRA 

1950 


CALL MOVEA ( RW ( I ) , ZWW (1,1) +RTICK ) 

1960 

195 

CALL DR AW A ( RW ( I ) , ZWW (I , NZCPl ) -RTICK) 

1970 

C 


1980 

C 


1990 


CALL MOVEA ( RW ( 1 ) , ZWW (1,1) + RTICK ) 

2000 

198 

CALL DAS HA ( RW ( 1 ) , ZWW(1 , NZCPl ) -RTICK, 3212 ) 

2010 

C 


2020 

C DRAW 

TICKS AT FURNACE ENDS AND MELT 

2030 

C 


2040 


RTICK = .05 * (RAMP - RINS) 

2050 

C 


2060 


CALL MOVEA ( RAMP , ZTTOP ) 

2070 


CALL DRAWR ( RTICK, 0. ) 

2080 

C 


2090 


CALL MOVEA( RAMP , ZTBOT ) 

2100 


CALL DRAWR ( RTICK, 0 . ) 

2110 

C 


2120 


CALL MOVEA ( RINS , FI NTH ( 2 ) ) 

2130 


CALL DRAWR( -RTICK, 0 . ) 

2140 

C 


2150 


CALL CZAXIS(O) 

2160 

C 


2170 

C 

MAIN LOOP OVER CELLS 

2180 

C 


2190 


DO 80 I = 1, MX - 1 - NHHI 

2200 


DO 70 K = 1, MY - 1 - NHHI 

2210 

C 


2220 

C GET 

4 CORNER VALUES ON WW MESH USING STATEMENT FUNCT 

2230 

C NHHI 

IS 0 FOR WW FUNCTIONS 

2240 

C 


2250 


VI = V ( I , K ) 

2260 


V2 = V ( 1+1 , K ) 

2270 


V 3 = V ( 1 + 1 , K+l ) 

2280 


V4 = V ( I , K+l ) 

2290 

C 


2300 

C 

K+l V4 S3 V3 

2310 

C 


2320 

C 

S4 S 2 
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2330 

2340 

2350 

2360 

2370 

2380 

2390 

2400 

2410 

2420 

2430 

2440 

2450 

2460 

2470 

2480 

2490 

2500 

2510 

2520 

2530 

2540 

2550 

2560 

2570 

2580 

2590 

2600 

2610 

2620 

2630 


2790 

2800 

2810 

2820 

2830 

2840 

2850 

2860 

2870 

2880 

2890 

2900 


C 

C 

C 

C 

C 

C 

C 


C 

C 

C 


K. 


VI 


SI 


V2 


1 + 1 


VMN = AMINl ( VI ,V2 ,V3 ,V4 ) 

VMX = AMAXl (VI ,V2 , V3 ,V4 ) 

CALCULATE INNER LOOP OVER CONTOURS 


IF 
LB 
LT 
IF 
DO 
IF 

IF (VMX .GT. 
CONTINUE 


GT. VMX). OR. (VMN .GT. CONTVL ( NCONTN ) ) ) GO TO 70 


( ( CONTVL ( 1 ) 

= 1 

= NCONTN 

(NCONTN .EQ. 1.) GO TO 110 
90 L = 1, NCONTN 
(VMN .GT. CONTVL (L)) LB 
CONTVL (L)) LT 


= L 
= L 


+ 1 


90 
C 

C DO INNER LOOP OVER CONTOURS 
C 

110 


DO 60 L = LB , LT 
CONTPV = CONTVL ( L ) 
IF (CONTPV .EQ. 0. 
Q1 = VI -CONTPV 
Q2 = V2- CONTPV 
Q3 = V3- CONTPV 
Q 4 = V4- CONTPV 


.AND, 


AC .LT. 0. ) GO TO 60 


2640 


IF 

( Q1 -EQ 

. 0 . ) Q1 

= VINC 

* 

1 .E-6 

2650 


IF 

(Q2 .EQ 

. 0. ) Q2 

= VINC 

* 

1 .E-6 

2660 


IF 

( Q3 .EQ 

. 0.) Q3 

= VINC 

★ 

1 .E-6 

2670 


IF 

(Q4 .EQ 

. 0. ) Q4 

= VINC 

* 

1 .E-6 

2680 

C 







2690 


ONE 

= 1 





2700 


Tl 

= SIGN 

( ONE , Ql ) 




2710 


T2 

= SIGN 

( ONE , Q2 ) 




2720 


T3 

= SIGN 

( ONE , Q3 ) 




2730 


T4 

= SIGN 

( ONE , Q4 ) 




2740 

C 







2750 


SI 

= Tl * 

T2 




2760 


S2 

= T2 * 

T3 




2770 


S3 

= T3 * 

T4 




2780 


S4 

= T4 * 

Tl 





10 


20 


IF (SI .GE. 0) GO TO 10 

CALL MOVEA ( RW ( I ) +Ql/(Q1 -Q2 )/DIDRH( 1+1 ) , 

1 ZWW ( I / K ) + ( ZWW ( 1+1 , K ) - ZWW ( I ,K ) ) *Ql/( Q1 -Q2 ) ) 

IF ( S2 .GE. 0 ) GO TO 20 

CALL DRAWA ( RW ( 1+1 ) , ZWW( 1+1 , K )+Q2/( Q2 -Q3 ) *DZDKWH( 1+1 ,K+1 ) ) 
GO TO 30 

IF (S2 .GE. 0) GO TO 30 

CALL MOVEA ( RW( 1+1 ) , ZWW ( 1+1 , K )+Q2/(Q2 -Q3 ) *DZDKWH( 1+1 , K+l ) ) 
IF ( S3 .GE. 0 ) GO TO 40 

CALL DRAWA ( RW( I ) +Q4/(Q4 -Q3 )/DIDRH( 1+1 ) , 

1 ZWW( I ,K+1 ) + ( ZWW( 1+1 ,K+1 ) -ZWW( I , K+l ) ) *Q4/(Q4 -Q3 ) ) 
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2910 


GO TO 50 

2920 

30 

IF (S3 .GE. 0) GO TO 50 

2930 


CALL MOVE A ( RW ( I ) + Q4/ ( Q4 -Q3 ) /DIDRH { 1+1 ) , 

2940 


1 ZWW( I , K+l )+ ( ZWW( 1+1 ,K+1 ) -ZWW( I , K+l ) ) *Q4/(Q4 -Q3 ) ) 

2950 

40 

IF ( S4 .LT. 0) 

2960 


1 CALL DRAWA( RW( I ) , ZWW( I , K ) +Ql/( Q1 -Q4 ) *DZDKWH( I ,K + 1 ) ) 

2970 

50 

CONTINUE 

2980 

60 

CONTINUE 

2990 

70 

CONTINUE . ; 

3000 

80 

CONTINUE 

3010 

C 


3020 


CALL HDCOPY 

3030 


CALL CLTERM 

3040 

C 


3050 


RETURN 

69060 


END 
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10 SUBROUTINE MESHPL ( RPLL , RPLR , ZPLB , ZPLT ) 

20 C 

30 C PLOT MESH CURVES ON THE TEKTRONIX IN WORLD SPACE 
40 C 

50 INCLUDE ' COM. /NOLIST' 

60 C 

70 CHARACTER *40 BLANK 

80 DATA BLANK /' '/ 

90 C 

100 C ZWW FROM STATEMENT FUNCTION 

110 c 

120 ZWW ( I , K ) = ZETW(K) + ETAW(K) * RFINTW(I) 

130 C 
140 C 

150 C CLEAR SCREEN 

160 C GET TERMINAL WINDOW AND RATIO 


170 

C 




180 



CALL 

INTERM 

190 



CALL 

SEETW (MINX, MAXX, MINY, MAXY) 

200 



MB = 

MAXX / 50 

210 



MINX 

= MINX + MB 

220 



MI NY 

= MINY + MB 

230 



MAXX 

= MAXX - MB 

240 



MAXY 

= MAXY - MAX ( MB , MAXX/2 0 ) 

250 

C 




260 



XR = 

MAXX - MINX 

270 



YR = 

MAXY - MINY 

280 

C 




290 

C 

GET 

NUMBER 

OF LINES OF TEXT AND RASTER EQUIVALENT 

300 

C 

GET 

MAXIMUM NUMBER OF CHARACTERS AND RASTER EQUIVALENT 

310 

C 




320 



NLT 

= 2 

330 



RNLT 

= NLT * YR / NLPP 

340 

C 




350 



LD = 

LENGTH ( DESCR , 44 ) 

360 



MNC 

= MAX (24, LD ) + 6 

370 



RMNC 

= MNC * XR / NCPL 

380 

C 




390 

C 

GET 

RECTANGLE HEIGHT, WIDTH, AND RATIO 

400 

C 




410 



HR = 

ZPLT - ZPLB 

420 



WR = 

(RPLR - RPLL).* RSTRPL 

430 



HOW 

= HR / WR 

440 

c 




450 

c 

GET 

SCALE 

WITH TEXT AT LEFT 

460 

c 





470 SCALEL = MAX ( HR/YR , WR/ ( XR - RMNC ) ) 

480 C 

490 C GET SCALE WITH TEXT AT BOTTOM 
500 C 

510 SCALEB = MAX ( HR/ ( YR - RNLT ) , WR/XR ) 

520 SCALE = MIN ( SCALEL , SCALEB ) 

530 C 

540 C PLACE TEXT AND TERMINAL WINDOW FOR LEFT 
550 C 

560 IF (SCALEL .LT. SCALEB) THEN 

570 C 
580 


NBL 


( NLPP - NLT ) / 2 
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590 

C 


600 


NBC = 1 + NBCPL 

610 

C 


620 


MINX = MINX + RMNC 

630 


MI NY = MI NY + (YR/2) * MAX ( 0 . , 1 . - HOW/ ( YR/ ( XR - RMNC ) ) ) 

640 

C 


650 

C PLACE 

TEXT AND TERMINAL WINDOW FOR BOTTOM 

660 

C 


670 


ELSE 

680 

C 


690 


NBL = NLPP - NLT 

700 


NBC = 1 + NBCPL + ( NCPL - MNC ) / 2 

710 

C 

• : _ - . - 

720 


MI NY = MINY + RNLT 

730 


MINX = MINX + ( RX/2 ) * MAX( 0 . , 1 . - ( ( YR- RNLT ) /XR )/HOW ) 

740 

C 


750 


ENDIF 

760 

C 


770 

c GET THE OPPOSITE CORNER OF THE WINDOW 

780 

C 


790 


MAXX = MINX + WR / SCALE ORIGINAL PAGE 13 

800 


MAXY = MINY + HR / SCALE qj pg 0R QUALITY 

810 

C 


820 

C TEXT 

ON PLOT 

830 

C 


840 


DO 120 IBL = 1, NBL-NLPA 

850 

120 

WRITE (1,130) 

860 

130 

FORMAT (IX) 

870 


WRITE ( 1,140) BLANK (1:NBC) ,DESCR(1:LD) 

880 


WRITE ( 1, 140 )BLANK ( 1 :NBC) , 'COMPUTATIONAL MESH' 

890 

140 

FORMAT (A, A) 

900 

C 


910 

C SET PLOT WINDOW AND TRANSFORM 

920 

C 


930 


EPSW = .02 

940 

c 


950 


RPWL = RPLL - EPSW * WR / RSTRPL 

960 


RPWR = RPLR + EPSW * WR / RSTRPL 

970 


ZPWB = ZPLB - EPSW * HR 

980 


ZPWT = ZPLT + EPSW * HR 

990 

c 

“ ' 

1000 


CALL DWINDO( RPWL, RPWR, ZPWB, ZPWT) 

1010 

c 


1020 


CALL TWINDO ( MINX , MAXX , MINY , MAXY ) 

1030 

c 


1040 

c 


1050 

C DRAW 

MESH, EXCLUDING BOUNDARIES, INCLUDING INTERFACE 

1060 

C 


1070 


DO 192 K = 2, NZC 

1080 


CALL MOVEA ( RW ( 1 ) , ZWW ( 1 , K ) ) 

1090 


DO 190 1=2, NRCPl 

1100 

190 

CALL DRAWA ( RW ( I ) , ZWW ( I , K ) ) 

1110 

192 

CONTINUE 

1120 

C 


1130 


DO 197 I = 2, NRC 

1140 


IF (I .EQ. NRPl ) GO TO 197 

1150 


CALL MOVEA ( RW ( I ) , ZWW( 1,1)) 

1160 

195 

CALL DRAWA ( RW ( I ) , ZWW( I ,NZCPl ) ) 
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1170 

197 

CONTINUE 

1180 

C 



1190 

C 

DRAW 

BOUNDARIES AND INTERFACES 

1200 

C 



1210 



IF (IMACH .NE. 2) CALL CZAXIS(l) 

1220 



RTICK = .05 * (RAMP - RINS) 

1230 

C 



1240 

C 

DASH 

TOP AND BOTTOM 

1250 

C 


- 

1260 



DO 290 K = 1 , NZCPl , NZC 

1270 



CALL MOVEA ( RW ( 1 ) , ZWW ( 1 , K ) ) 

1280 



I = NRCPl 

1290 

290 

CALL DASHA ( RW ( I ) , ZWW(I,K) ,12) 

1300 

C 



1310 

C 

DASH 

INTERFACE SEGMENT 

1320 

C 



1330 

C 


CALL MOVEA ( RW ( 1 ) , ZWW ( 1 , NZ P 1 ) ) 

1340 

C 


DO 292 1=2, NRPl 

1350 

C292 

CALL DASHA ( RW ( I ) , ZWW ( I , NZPl ) , 31 ) 

1360 

C 



1370 

C 

INSIDE AND OUTSIDE OF AMPOULE 

1380 

C 



1390 



DO 295 I = NRPl, NRCPl, NRA 

1400 



CALL MOVEA ( RW ( I ) , ZWW ( I , 1 ) +RTICK ) 

1410 

295 

CALL DR AW A ( RW ( I ) , ZWW ( I , NZCPl ) -RTICK) 

1420 

C 



1430 

C 

DASH 

AXIS 

1440 

C 



1450 



CALL MOVEA ( RW ( 1 ) , ZWW (1,1) +RTICK ) 

1460 

298 

CALL DASHA (RW( 1 ) , ZWW( 1 , NZCPl ) -RTICK, 3212 ) 

1470 

C 



1480 

C 

DRAW 

TICKS AT FURNACE ENDS AND MELT 

1490 

C 



1500 



CALL MOVEA ( RAMP , ZTTOP) 

1510 



CALL DRAWR( RTICK, 0 . ) 

1520 

C 



1530 



CALL MOVEA ( RAMP, ZTBOT) 

1540 



CALL DRAWR ( RTICK, 0 . ) 

1550 

C 



1560 



CALL MOVEA ( RINS , FI NTH ( 2 ) ) 

1570 



CALL DRAWR ( -RTICK, 0 . ) * 

1580 

C 



1590 



CALL CZAXIS(O) 

1600 

C 



1610 

C 



1620 



CALL HDCOPY 

1630 



CALL CLTERM 

1640 

r* 

U 



1650 



RETURN- 

61600 



END 
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10 

20 

30 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 

210 

220 

230 

**\ a n, 

Z 4 U 

250 

260 

270 

280 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


SUBROUTINE LINEPL 
C 

C LINE PLOT OUTPUT 
C 

INCLUDE 'COM. /NOLIST' 

C 

C EQUIVALENCE STATEMENTS TO ALLOCATE SPACE FOR THE ARRAYS 
C 

PARAMETER ( NKMAX = 2, NT MAX = 21) - 

DIMENSION VAR (NZP2, NKMAX, NTMAX) ,RAR(NZP2) , TAR ( NTMAX ) 

EQUIVALENCE ( DT , VAR ) 

CHARACTER *120 BLANK 
DATA BLANK /' '/ 

C 

C LOOP OVER PLOT TYPES IN . Ynn FILE PRODUCED BY PRNT AND MOVIE IN PRIOR 
C 

DO 200 I APC = 2, NAPC 

IF ( NSTEP .LT. I PC ( 5 , IAPC ) .OR. IPC(6,IAPC) .GT. 0) GO TO 200 
C 

C GET NUMBER OF TIMES 

C IF THE RUN FAILED, THE NUMBER WRITTEN MAY BE SMALLER, 

C AND NT IS RESET WHEN THE READ FAILS. 

C 

NT = (NSTEP - I PC ( 5 , IAPC ) ) / ABS { IPC ( 6 , IAPC ) ) + 1 

NT = MIN (NT, NTMAX) 

C 

C NT IS WRONG IF IPC(7,IAPC) IS NOT NEGATIVE 
C 

IF (I PC (7, I APC) .GE. 0) NT = NTMAX 
C 

C GET RANGES FOR I AND K 
C 

11 = ABS(IPC(7,IAPC) ) 

12 = IPC ( 8 , IAPC ) 

13 = IPC ( 9 , IAPC ) 

NI = 1 + ( 12 - II )/I 3 
C 

Kl = IPC (10, IAPC ) 

K2 = IPC (11, IAPC ) 

K3 = I PC ( 1 2 , IAPC ) 

NK = 1 + (K2-K1)/K3 - ' 

NKS = NK 
C 

C GET STREAM NUMBER 
C OPEN OLD FILE 
C 

IS = 40 + IAPC 
CALL SQOPN(IS,2) 

C 

c READ HEADER 
C 

READ (IS) DESCR 
READ (IS) LTITLE ( IAPC ) 

1 , IB , IE , NI 

1 , KB , KE , NKI 

C 
C 


DO 40 KT 


1, NT 


t 
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590 

C 



600 



READ ( IS , ERR=41 ) I STEP , TTIMR 

610 

30 


FORMAT( ' ISTEP =',I8,F14.7) 

620 



TAR(KT) = TTIMR 

630 



READ (IS) ( (VAR(I,K,KT) , 1=1 1 , I 2 , I 3 ) , K=1 , NKS ) 

640 

C 



650 



DO 60 I = 11, 12, 13 

660 



DO 60 K = 1, NK 

670 



VMAX = MAX ( VMAX , VAR ( I ,K,KT) ) 

680 



VMIN = MIN ( VMIN , VAR ( I , K , KT ) ) 

690 

60 


CONTINUE 

700 

C 



710 

40 


CONTINUE 

720 



GO TO 42 

730 

41 


NT = KT - 1 

740 

42 


CONTINUE 

750 

C 



760 

C 

CLOSE FILE AT END. 

770 

C 



780 



CLOSE ( UNI T= I S ) 

790 

C 



800 




810 

C 



820 

c 

NO PLOT IF MAX = MIN 

830 

c 



840 



IF (VMAX .EQ. VMIN) GO TO 200 

850 

c 



860 

c 

GET 

ROUNDED V PLOT RANGE 

870 

c 



880 



VINC = ROUND ( (VMAX- VMIN)/4 .3) 

890 



I = VMAX/ VINC + 9999 

900 



IMAX = I - 9998 

910 



I = VMIN/VINC + 9999 

920 



IMIN = I - 9999 

930 



VP MAX = VINC * IMAX 

940 



VPMIN = VINC * IMIN 

950 

c 



960 

c 

INITIALIZE TERMINAL 

970 

c 



980 



CALL INTERM 

990 

c 



1000 

c 

GET 

TERMINAL WINDOW AND RATIO 

1010 

c 



1020 



CALL SEETW ( MINX , MAXX , MINY , MAXY ) 

1030 



MB = MAXX / 40 

1040 



MINX = MINX + MB * 3 

1050 



MINY = MINY + MB * 3 

1060 



MAXX = MAXX - MB 

1070 



MAXY = MAXY - MB 

1080 

c 



1090 



XR = MAXX - MINX 

1100 



YR = MAXY - MINY 

1110 

c 



1120 

c 

GET 

NUMBER OF LINES OF TEXT AND RASTER EQUIVALENT 

1130 

c 

GET 

MAXIMUM NUMBER OF CHARACTERS AND RASTER EQUIVALENT 

1140 

c 



1150 



NLT = 7 

1160 



IF (NY .NE. 1) NLT = NLT + 1 
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1170 

1180 

1190 

1200 

1210 

1220 

1230 

1240 

1250 

1260 

1270 

1280 

1290 

1300 

1310 

1320 

1330 

1340 

1350 

1360 

1370 

1380 

1390 

1400 

1410 

1420 

1430 

1440 

1450 

1460 

1470 

1480 

1490 

1500 

1510 

1520 

1530 

1540 

1550 

1560 

1570 

1580 

1590 

1600 

1610 

1620 

1630 

1640 

1650 

1660 

1670 

1680 

1690 

1700 

1710 

1720 

1730 

1740 


RNLT = NLT * YR / NLPP 

MNC = MAX (24, LENGTH ( DESCR , 4 4 ) ) + 6 

RMNC = MNC * XR / NCPL 


C 

Q PLACE TEXT AND TERMINAL WINDOW FOR BOTTOM 

c ORIGINAL PAGE 

NBL = NLPP - NLT - NLPA Qp pQOR QUALITY 

NBC = 1 + (NCPL - MNC) / 2 
MINY = MINY + RNLT 


C 

C TEXT ON PLOT 
C 

DO 120 IBL = 1, NBL 
120 WRITE ( IUPLOT ,130) 

130 FORMAT (IX) 

WRITE (IUPLOT, 140 ) BLANK ( 1:NBC) , LTITLE ( IAPC ) 

WRITE ( IUPLOT, 140 ) BLANK ( 1 :NBC) , DESCR 

140 FORMAT ( A, A ) 

WRITE ( IUPLOT, 150 ) BLANK ( 1 :NBC) ,VMAX 
WRITE ( IUPLOT, 160 ) BLANK ( 1 :NBC) ,VMIN 

IF (NT .GT. 1) WRITE ( IUPLOT , 1 8 0 ) BLANK ( 1 : NBC ), TAR ( 1 ), TAR ( NT 
IF (NT . EQ . 1 .AND. TAR ( 1 ) .NE. 0) 

1 WRITE ( IUPLOT ,181) BLANK ( 1 :NBC ) , TAR ( 1 ) 

WRITE ( IUPLOT ,195) BLANK ( 1 : NBC ) , VINC*IMIN , VINC* IMAX , VI NC 
150 FORMAT (A, 'MAXIMUM =',1PG13.5) 

160 FORMAT (A, 'MINIMUM =',1PG13.5) 

180 FORMAT (A, 'TIME RANGE ', F7 . 0 , ' TO',F9.0) 

181 FORMAT (A, 'TIME ',F8.0) 

195 FORMAT ( A , ' V RANGE ' , 1P2E1 0 . 2 , ' BY',El0.2) 

C 

C SET PLOT WINDOWS 
C 

CALL TWINDO ( MINX , MAXX , MINY , MAXY ) 


) 


C 

DR = .02* (RSAM-RINS) 

CALL DWINDO ( RINS - DR , RSAM+DR 
1 , VINC* ( - . 1+IMIN ) ,VINC*(+. 1+IMAX) ) 

C 

C DRAW AXES 
C 

CALL MO VEA ( R I N S , VP MAX ) 

CALL DRAWA (RINS, VP MIN) 

CALL DRAWA ( RSAM , VPMIN ) 


C 

C DRAW V MARKERS 
C 

DO 90 I = IMIN, IMAX 

V = I * VINC 

CALL MOVEA (RINS,V) 

90 CALL DRWREL ( -15,0) 

C 

C DRAW PLOTS 
C 

DO 70 KT - 1, NT 
TTIMR = TAR(KT) 

DO 65 I = II, 12, 1 3„ 
65 RAR(I) = RH(I) 
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1750 

1760 

1770 

1780 

1790 

1800 

1810 

1820 

1830 

1840 

1850 

1860 

1870 

1880 

1890 

1900 

1910 

1920 

1930 

1940 

1950 

1960 

1970 

1980 

1990 

2000 

2010 

2020 

2030 

2040 

2050 

2060 

2070 


C CLEAN 
C 


66 


UP ENDS 

IF (II .EQ. 1) THEN 

RAR(l) = RINS 
IF (13 .EQ. 1) THEN 

DO 66 K = 1, NK 

VAR ( 1 , K , KT ) = . 5 * ( VAR ( 1 , K , KT ) +VAR ( 2 , K , KT ) ) 

END IF 

ENDIF 


68 


IF (12 .EQ. NRP2) THEN 

RAR ( NRP2 ) = RSAM 
IF (13 .EQ. 1) THEN 

DO 68 K = 1, NK 

VAR ( NRP 2 , K , KT ) = . 5 * ( VAR ( NRP 2 , K , KT ) +VAR ( NRP 1 , K , 

ENDIF 

ENDIF 


70 

C 

C 

200 

C 


DO 70 K = 1, NK 

CALL MOVEA ( RAR ( I 1 ) , VAR ( 1 1 , K , KT ) ) 
DO 70 I = 11+13 , 12, 13 
CALL DRAWA ( RAR ( I ) , VAR ( I , K , KT ) ) 
CONTINUE 

CALL HDCOPY 

CONTINUE 

CALL CLTERM 


RETURN 

END 
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10 SUBROUTINE MDIAG 

20 C 

30 C MESH DIAGNOSTIC LINE EVERY NDIAG STEPS. 

40 C 

50 INCLUDE ' COM. /NOLIST' 

60 C 

70 IF ( LCONT .OR. .NOT. DIAG) RETURN 

80 C 

90 C WRITE HEADING 
100 C 

110 IF (ISTEP .EQ. 0) WRITE (30,10) 

120 10 FORMAT ( 1H1 , T4 0 INTERFACE DIAGNOSTICS'// 

130 1 ' ISTEP FMAX ( I MAX ) FMIN(IMIN) 

140 1 DFMAX ( I MAX ) DFMIN ( IMIN ) ' 

150 1 TINTMAX( IMAX ) TINTMIN ( IMIN ) ' 

160 1 DTINTMAX( IMAX) DTINTMIN ( IMIN ) ' / ) 

170 C 

180 C GET DIAGNOSTICS 

190 C MXMN LOOKS ONLY AT THE INTERIOR OF A 2D ARRAY (ASSUMING THE BOUNDARY 

200 C IS DETERMINED BY BOUNDARY CONDITIONS). HENCE THESE WEIRD ARGUMENTS. 

210 C 

220 CALL MXMN ( FI NTH ( 1 - NRP2 ) , NRP2 , 3 

230 1 , FMAX , JMAX , MAXD , FMIN, JMIN, MIND, 3 , 2 ) 

240 CALL MXMN ( DFINTH ( 1 - NRP2 ) , NRP2 , 3 

250 1 , DFMAX, IMAX, MAXD, DFMIN, IMIN, MIND, 3, 2) 

260 CALL MXMN ( TINTH ( 1 - NRP2 ) , NRP2 , 3 

270 1 , TMAX , KMAX , MAXD , TMIN, KMIN,MIND ,3,2) 

280 CALL MXMN ( DTINTH ( 1 - NRP2 ) , NRP2 , 3 

290 1 , DTMAX , LMAX , MAXD , DTMIN, LMIN , MIND ,3,2) 

300 C 

310 C WRITE DIAGNOSTICS 
320 C 

330 WRITE (30,30) ISTEP, 

340 1 FMAX, JMAX, FMIN, JMIN 

350 1 , DFMAX, IMAX, DFMIN, IMIN 

360 1 , TMAX, KMAX, TMIN , KMIN 

370 1 , DTMAX, LMAX, DTMIN, LMIN 

380 30 FORMAT ( IX , I 4 , IX , 2 ( F9 . 5 , ' ( ' , 1 3 , ' ) ' ) , 

390 1 2X, 2(F11.7, ' ( ' ,13, ' ) ' ) , 

400 1 2X,2(F10.4,'(',I3,')') , 

410 1 2X , 2 ( F-l 0 . 6 , ' ( ' , 1 3 , ' ) ' ) ) 

420 C 

430 C CLEAN TERMINATION ON INSTABILITY 
440 C 

450 FRNGE = 0.9 * ( RSAM - RINS ) 

460 DFRNGE = .07 * (RSAM - RINS) * (1. + NSTEP/ ( 1 . +1 STEP ) ) 

470 C 

480 IF ( FMAX - FMIN .GT. FRNGE ) CALL CEXT ( CGROW ,40,2, ' FR ' ) 

490 IF ( DFMAX - DFMIN . GT . DFRNGE ) CALL CEXT ( CGROW , 4 0 , 2 , ' DF ' ) 

500 C 

510 RETURN 

65530 END 
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10 


SUBROUTINE TDIAG 

20 

C 


30 

C T DIAGNOSTIC LINE EVERY NDIAG STEPS. 

40 

C 


50 


INCLUDE ' COM . /NOLIST ' 

60 

c 


70 


IF ( LCONT .OR. .NOT. D I AG ) RETURN 

80 

c 


90 

C WRITE 

HEADING 

100 

C 


110 


IF (ISTEP .EQ. 0) WRITE (*,10) 

120 


IF (ISTEP .EQ. 0) WRITE (31,10) 

130 

10 

FORMAT ( lHl , T4 0 , ' T DIAGNOSTICS'// 

140 


1 ' ISTEP TMAX ( I MAX , KMAX ) TMIN ( IMIN , KMIN ) 

150 


1 ,' DTMAX( IMAX, KMAX) DTMIN ( IMIN , KMIN ) ' 

160 


1 , ' FBOT FTOP FRITE FINT 

170 

C 


180 

C GET DIAGNOSTICS 

190 

C 


200 


RSUM = ( FRITE + FBOT + FTOP + FINT ) 

210 


1 / (l.E-20 + ABS ( FRITE ) + ABS(FBOT) + ABS(FTOP) 

220 

c 


230 


CALL MXMN ( T , NRCP2 , NZCP2 

n a r\ 


1 , TMAX , JMAX , LMAX , TMIN , JMIN , LMIN ,3,3) 

250 


CALL MXMN(DT,NRCP2 ,NZCP2 

260 


1 , DTMAX , IMAX, KMAX, DTMIN, IMIN, KMIN, 3,3) 

270 

c 


280 

C WRITE 

DIAGNOSTICS 

290 

c 


300 


WRITE (*,30) ISTEP, 

310 


1 TMAX, JMAX, LMAX, TMIN, JMIN, LMIN 

320 


1 , DTMAX, IMAX, KMAX, DTMIN, IMIN, KMIN 

330 


1 , FBOT, FTOP, FRITE, FINT, RSUM 

340 


WRITE (31,30) ISTEP, 

350 


1 TMAX, JMAX, LMAX, TMIN, JMIN, LMIN 

360 


1 , DTMAX, IMAX, KMAX, DTMIN, IMIN, KMIN 

370 


1 ,FBOT, FTOP, FRITE, FINT, RSUM 

380 

30 

FORMAT ( IX , I 4 , 2X , 2 ( F7 . 2 , ' ( ' , 1 3 , ' , ' , 1 3 , ' ) ' ) , 

390 


1 2X,2(F9.4, ' ( ' ,13, ' , ' ,13, ' ) ' ) 

400 


1 ,1P4E12.3,0PF8.4) 

410 

c 

- 

420 

c CLEAN 

TERMINATION ON INSTABILITY 

430 

C 


440 


TRNGE = ( TTOP - TBOT ) * 1.5 

450 


DTRNGE = (TTOP - TBOT) * 0.3 * (1. + NSTEP/ ( 1 . +1 STEP ) 

460 

c 

IF ( TMAX - TMIN .GT. TRNGE ) CALL CEXT (CGROW,40,: 

470 


480 


IF ( DTMAX - DTMIN .GT. DTRNGE ) CALL CEXT (CGROW,40, 

490 

c 


500 


RETURN 

65520 


END 


J 


RSUM 


ABS( FIN 


' TR' ) 
' DT ' ) 
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10 



SUBROUTINE CDIAG 

20 

C 



30 

C C DIAGNOSTIC LINE EVERY NDIAG STEPS. 

40 

C 



50 



INCLUDE ' COM ./NOLIST ' 

60 

C 



70 



IF ( LCONT .OR. .NOT. DIAG ) RETURN 

80 

c 



90 

C WRITE 

HEADING 

100 

C 



110 



IF (ISTEP .EQ. 0) WRITE (32,10) 

120 

10 


FORMAT ( 1H1 , T40 , ' C DIAGNOSTICS'// 

130 



1 ' ISTEP CMAX ( I MAX , KMAX ) CMIN ( IMIN , KMIN 

140 



1 RDCMAX ( I MAX , KMAX ) RDCMIN ( IMIN , KMIN ) ' 

150 



1 , ' XINT XTOP RSUM ' / ) 

160 

C 



170 

C GET 

DIAGNOSTICS 

180 

C 



190 



RSUM = ( XINT + XTOP ) 

200 



1 / (l.E-20 + ABS(XINT) + ABS(XTOP) ) 

210 

C 



220 



CALL MXMN ( C , NRP2 , NZP2 

230 



1 , CMAX , JMAX , LMAX , CMIN , JMIN , LMIN , 3,3) 

240 



CALL MXMN ( DC , NRP2 , NZP2 

250 



1 , DCMAX , IMAX , KMAX , DCMIN , IMIN , KMIN , 3,3) 

260 

C 



270 

C GET 

RELATIVE CHANGE EXTREMA 

280 

C 



290 



CDIF = CMAX - CMIN 

300 



IF (CDIF .EQ. 0. ) CDIF = 1 

310 



DCMAX = DCMAX / CDIF 

320 



DCMIN = DCMIN / CDIF 

330 

C 



340 

C WRITE 

DIAGNOSTICS 

350 

c 



360 



WRITE (32,30) ISTEP, 

370 



1 CMAX, JMAX, LMAX, CMIN, JMIN, LMIN 

380 



1 , DCMAX, IMAX, KMAX, DCMIN, IMIN, KMIN 

390 



1 , XINT, XTOP, RSUM 

400 

30 


FORMAT (1X,I4,2X,2(F10.5,'(',I3,',',I3,')'), 

410 



1 2X, 2 ( F-12 . 7 , ' ( ' , 13 , ' , ' , 13 , ' ) ' ) 

420 



1 , 1P2E12 . 3 , 0PF8 . 4 ) 

430 

C 



440 

C CLEAN 

TERMINATION ON INSTABILITY 

450 

c 



460 



CRNGE = 3 *MAX ( CTOP , CMELT ) 

470 



DCRNGE = CRNGE*. 3 * (1. + NSTEP/( 1 . +1 STEP ) ) 

480 

r* 



490 



IF ( CMAX - CMIN .GT. CRNGE ) CALL CEXT (CGROW,40, 

500 



IF ( DCMAX - DCMIN . GT . DCRNGE ) CALL CEXT (CGROW,40 

510 

C 



520 



RETURN 

65530 



END 


t 


'CR' ) 
f DC' ) 
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10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
6 5100 


SUBROUTINE PDIAG 
C 

C PSI DIAGNOSTIC LINE EVERY NDIAG STEPS. 

C 

INCLUDE 'COM. /NOLIST' 

C 

IF ( LCONT .OR. .NOT. DIAG) RETURN 
C 

C WRITE HEADING 
C 

IF (ISTEP .EQ. 0) WRITE (33,10) 

10 FORMAT (1H1,T40, 'PSI DIAGNOSTICS'// 

1 ' ISTEP PSI MAX ( I MAX , KMAX ) PSIMIN ( IMIN , KMIN ) 

1 ,' DPS I MAX ( I MAX , KMAX ) DPSIMIN ( IMIN , KMIN )'/ ) 

C 

c GET DIAGNOSTICS 
C 

CALL MXMN ( PSI , NRP2 , NZP2 

1 , PMAX , JMAX , LMAX , PMIN , JMIN , LMIN ,3,3) 

CALL MXMN ( DP SI , NRP2 ,NZP2 

1 , DPMAX , IMAX, KMAX, DPMIN, IMIN, KMIN, 3 , 3 ) 

C 

C WRITE DIAGNOSTICS 
C 

WRITE (33,30) ISTEP, 

1 PMAX, JMAX, LMAX, PMIN, JMIN, LMIN 

1 , DPMAX, IMAX, KMAX, DPMIN, IMIN, KMIN 

30 FORMAT ( IX , 1 4 , 2X , 2 ( F10 . 5 , ' ( ' , 1 3 , ' , ' , 1 3 , ' ) ' ) , 

1 2X,2(F12.7, ' ( ' ,13, ' , ' ,13, ' ) ' ) ) 

C 

C CLEAN TERMINATION ON INSTABILITY 
C 

PRNGE = 9999 
DPRNGE = 9999 

Q 

IF ( PMAX - PMIN .GT. PRNGE ) CALL CEXT ( CGROW , 4 0 , 2 , f PR ) 
IF ( DPMAX - DPMIN . GT . DPRNGE ) CALL CEXT ( CGROW , 4 0 , 2 , 9 DP ' ) 

C 

RETURN 

END 
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10 



SUBROUTINE VDIAG 

20 

C 



30 

C 

VORT DIAGNOSTIC LINE EVERY NDIAG STEPS. 

40 

C 



50 



INCLUDE ' COM. /NOLIST' 

60 

C 



70 



IF ( LCONT .OR. .NOT. DIAG ) RETURN 

80 

C 



90 

C 

WRITE 

HEADING 

100 

C 



110 



IF (ISTEP .EQ. 0) WRITE (34,10) 

120 

10 

FORMAT (1H1,T40, 'VORTICITY DIAGNOSTICS'// 

130 



1 ' ISTEP VORTMAX ( I MAX , KMAX ) VORTMIN( IMIN, KMIN 

140 



1 DVORTMAX ( I MAX , KMAX ) DVORTMIN ( IMIN , KMIN )' , 

150 

C 



160 

C 

GET DIAGNOSTICS 

170 

C 



180 



CALL MXMN ( VORT , NRPl , NZPl 

190 



1 , VMAX , JMAX , LMAX , VMIN , JMIN , LMIN ,3,3) 

200 



CALL MXMN ( DVORT, NRPl , NZPl 

210 



1 , DVMAX , IMAX, KMAX, DVMIN, IMIN, KMIN, 3, 3 ) 

220 

C 



230 

C 

WRITE 

DIAGNOSTICS 

240 

C 



250 



WRITE (34,30) ISTEP, 

260 



1 VMAX, JMAX, LMAX, VMIN, JMIN, LMIN 

270 



1 , DVMAX, IMAX, KMAX, DVMIN, IMIN, KMIN 

280 

30 

FORMAT ( IX , 1 4 , 2X , 2 ( F10 . 5 , ' ( ' , 1 3 , ' , ' , 1 3 , ' ) ' ) , 

290 



1 2X,2(F12.7, ' ( ' ,13, ' , ' ,13, ' ) ' ) ) 

300 

C 



310 

C 

CLEAN 

TERMINATION ON INSTABILITY 

320 

C 



330 



VRNGE = 9999 

340 



DVRNGE = 9999 

350 

C 



360 



IF ( VMAX - VMIN .GT. VRNGE ) CALL CEXT (CGROW,40, 

370 



IF ( DVMAX - DVMIN . GT . DVRNGE ) CALL CEXT (CGROW,40, 

380 

C 



390 



RETURN 

400 



END 


' VR ' ) 
’ DV' ) 
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10 


SUBROUTINE PRNT ( VAR , ND , IAPC ) 

20 

C 


30 

C PRINTER ARRAY OUTPUT 

40 

C 


50 


INCLUDE 'COM. /NOLIST' 

60 

c 


70 


DIMENSION VAR ( ND , 1 ) 

80 

c 


90 


DIMENSION RIN ( NRCP2 ) 

100 


DIMENSION ZIN(NZCP2 ) 

110 


CHARACTER *8 CSHOWZERO 

120 


CHARACTER *6 TIMECC 

130 


DATA TIMECC /'TIME '/ 

140 

c 


150 

C GET PLOT DOMAIN AND I AND K RANGES FROM IAPC 

160 

C 


170 


RPLL = RINS 

180 


RPLR = RAMP 

190 


ZPLB = ZBPL 

200 


ZPLT = ZTPL 

210 

c 


220 


IF (IAPC .LE. 5) THEN 

230 


NCZ = NZCP2 

240 


NINTP = 2 

250 


ZCPB = ZPLB 

260 


RCPR = RAMP 

270 


ELSE IF (IAPC .LE. 11) THEN 

280 


ZPLB = 0 

290 


ZCPB = 0 

300 


ZPLT = 0 

310 


NCZ =1 

320 


ELSE IF (IAPC .GE. 14 .AND. IAPC . LE . 17) THEN 

330 


NCZ = NZPl 

340 


NINTP = 4 

350 


ZCPB = ZINT 

360 


RCPR = RSAM 

370 


ELSE 

380 


NCZ = NZP2 

390 


NINTP = 4 

400 


ZCPB = ZINT 

410 


RCPR = RSAM - • 

420 


ENDIF 

430 

c 


440 

c 

CONTOL TO INTERPOLATE HH POINTS TO WW FOR PLOTTING 

450 

c 


460 


IF (IAPC .GE. 14 .AND. IAPC .LE. 17) THEN 

470 


NHHI = 0 

480 


ELSE 

490 


NHHI = 1 

500 


ENDIF 

510 

c 


520 

c 

NUMBER OF CONTOURS 

530 

c 


540 


NCONT = 10 

550 


IF (IAPC .EQ. 2) NCONT = 20 

560 

c 


570 

c 

PLOTTER EXITS AND MESH CALL RETURN 

580 

c 
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590 

600 

610 

620 

630 

640 

650 

660 

670 

680 

690 

700 

710 

720 

730 

740 

750 

760 

770 

780 

790 

800 

810 

820 

830 

840 

850 

860 

870 

880 

890 

900 

910 

920 

930 

940 

950 

960 

970 

980 

990 

1000 

1010 

1020 

1030 

1040 

1050 

1060 

1070 

1080 

1090 

1100 

1110 

1120 

1130 

1140 

1150 

1160 


IF ( LCONT ) THEN 

CALL CPR ( VAR , ND , NCZ , IAPC , NCONT 
1 , NHHI , RPLL , RPLR , ZPLB , ZPLT ) 

RETURN 

ELSE 

IF (IAPC . EQ. 1) RETURN 

ENDIF 

C 

C NO CONTOUR PLOTS FOR ONE - DIMENS IONAL ARRAYS 
C 

IF (NCZ .EQ. 1) THEN 

C IF (LCONT) CALL PLOTl (VAR, ND, IAPC) 

GO TO 40 

ENDIF 


C 

c IS ZERO CONTOUR REQUIRED? 

C 

CSHOWZERO = ' SHOWZ ERO ' 

IF (IAPC .EQ. 3 ) CSHOWZERO = 'NOZERO' 

IF (IAPC .EQ. 13) CSHOWZERO = 'NOZERO' 

IF (IAPC .EQ. 15) CSHOWZERO = 'NOZERO' 

IF (IAPC .EQ. 17) CSHOWZERO = 'NOZERO' 

C 

C 

C CONTOUR AGAINST PHYSICAL VARIABLES. 

C 

J = ISTEP - I PC ( 1 , IAPC ) 

K = IPC ( 2 , IAPC ) 

IF ( ((J/K) * K .NE. J) .OR. (J .LT. 0) ) GO TO 20 


C 

C 

C 


CALL PLOTTER 


IF (IAPC .GE. 14 .AND. IAPC .LE. 17) THEN 
CALL CONTR ( VAR , RW , ZETW , ND , NCZ 
1 ,RPLL,RCPR,ZCPB,ZPLT 

1 , 1 , NCLP , 1 . , 7 

1 ,ACONT( IAPC) ,NCONT,l 

1 , 'NOSHADOW' , CSHOWZERO, 'OVERPRINT' ,NINTP 

1 , LTITLE ( IAPC ) , 42 , TIMECC , TTIME ) 

ELSE 


1 

1 

1 

1 

1 


CALL CONTR ( VAR , RH , ZETH , ND , NCZ 
, RPLL, RCPR,ZCPB, ZPLT 
, 1 , NCLP , 1 . ,7 
, ACONT ( IAPC) , NCONT , 1 

, 'NOSHADOW' , CSHOWZERO, 'OVERPRINT' ,NINTP 
, LTITLE ( IAPC) ,42, TIMECC, TTIME) 


20 

C 

C 

C 


ENDIF 

CONTINUE 


CONTOUR AGAINST INTEGERS 

J = ISTEP - IPC ( 3 , IAPC ) 

K = IPC ( 4 , IAPC ) 

IF ( ((J/K) * K .NE. J) -OR. (J .LT. 0) 


C 

DO 30 I = 1, ND 
30 RIN(I) = I 

DO 31 I = 1, NCZ 


) GO TO 40 
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1170 

31 

Z IN ( I ) = - I 

1180 

C 


1190 


XT = ND+ . 5 

1200 


YT = NCZ+.5 

1210 

C 


1220 


NLINC = NCLI 

1230 


IF (NLINC .EQ. 0) NLINC = NCZ 

1240 

C 


1250 


CALL CONTR ( VAR , RIN , ZIN , ND , NCZ 

1260 


1 , .5, XT, -YT, - .5 

1270 


1 , 1 , NLINC, 1 . , -4 

i 1280 


1 , ACONT ( I APC ) , NCONT , 1 

1290 


1 , 'NOSHADOW' ,CSHOWZERO, 'OVERPRINT' ,NINTP 

1300 


1 , LTI TLE ( I APC ) , 42 , TIMECC , TTIME ) 

1310 

C 


1320 

40 

CONTINUE 

1330 

C 


! 13 4 0 

C PRINT 

NUMBERS OR WRITE ARRAYS FOR MOVIE OR ID PLOTS. 

1350 

C CORRECT IPC8 AND 11 IF NECESSARY 

1360 

C 


1370 


I STB = I PC ( 5 , I APC ) 

1380 


J = ISTEP - I STB 

1390 


ISTI = I PC ( 6 , IAPC ) ^ 

1400 


IF ( ((J/ISTI) * ISTI .NE. J) -OR. (J .LT. 0) ) GO TO 100 

1410 

c 


1420 


11 = I PC ( 7 , IAPC ) 

1430 


12 = MIN( IPC( 8, IAPC) ,ND) 

1440 


13 = I PC ( 9 , IAPC ) 

1450 


Kl = I PC (10, IAPC ) 

1460 


K2 = MIN( IPC( 11 , IAPC) ,NCZ) 

1470 


K3 = IPC ( 12 , IAPC ) 

1480 

c 


1490 

C MOVIE 

JUMP CONDITION 

1500 

c 


1510 


IF (ISTI .LT. 0) GO TO 70 

1520 

C 


1530 

C HEADING 

1540 

c 


; 1550 


ICH = 1 0ilv TOrI n 

j 1560 


IF ( ( ( K2 + K3-K1 )/K3 ) * ( ( 12 + 13 -11 )/l3 ) .LT. 24) ICH - 0 

1570 


WRITE (6,45) ICH , LTITL-E ( IAPC ) , ISTEP , ( I , I = 11,12,13) 

1 1580 

45 

FORMAT ( I 1 /Tl 8 , A , ' AT ISTEP =',I4// (3X, 12110) ) 

1590 

C 


1600 

C VALUES 

1610 

c 


1620 


DO 50 K = Kl, K2, K3 

1630 

50 

WRITE (6,60) K , ( VAR ( I , K ) , I = 11,12,13) 

1640 

60 

FORMAT (/IX, 13 , 3X, 1P12E10 . 3/ (7X f 1P12E10 .3 ) ) 

1650 

c 


1660 


GO TO 100 

1670 

c 


1680 

C WRITE ARRAY FOR MOVIE 

1690 

C 


1700 

70 

CONTINUE 

1710 


CALL MOVIE ( VAR ,ND , IAPC , I 1 , 12 , 13 , Kl , K2 , K3 , ISTB , ISTI , J ) 

1720 

C 


1730 

100 

CONTINUE 

1740 

C 
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1750 

65560 


RETURN 

END 
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SUBROUTINE PRNTK (K,VAR,IAPC) 

20 

C 


30 

C PRINTER OUTPUT, LINE BY LINE. 

40 

C 


50 


INCLUDE ' COM. /NOLIST' 

60 

C 


70 


DIMENSION VAR ( 1 ) 

80 

c 


90 

C PRINT 

_ 

100 

C 


110 


J = ISTEP - I PC ( 5 , 1 APC ) 

120 


L = IPC ( 6 , IAPC ) 

130 


IF ( ((J/L) * L .NE. J) .OR. (J .LT. 0) ) GO TO 100 

140 

C 


150 


11 = I PC ( 7 , IAPC ) 

160 


12 = I PC ( 8 , IAPC ) 

170 


13 = IPC ( 9 , IAPC ) 

180 


Kl = IPC (10, IAPC ) 

190 


K2 = IPC (11, IAPC ) 

200 


K3 = I PC ( 1 2 , IAPC ) 

210 

C 


220 

C VALUES 

230 

C 


240 

48 

KK = K - Kl 

250 


IF (( ( K - Kl ) * ( K2 - K ) .GE. 0 ) .AND. (KK/K3*K3 . EQ . KK ) ) THEN 

260 

50 

WRITE (6,60) LTITLE( IAPC) ,K, (VAR( I ) , I = 11,12,13) 

270 

60 

FORMAT (/1X,A8 , 2X, 13 , 3X,1P12E10 . 3/ ( 13X, 1P12E10. 3 ) ) 

280 


END IF 

290 

C 


300 

100 

CONTINUE 

310 

C 


320 


RETURN 

6533B 


END 
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10 


FUNCTION PRTEST ( IAPC ) 

20 

C 


30 

C TEST 

IF FUNCTION IS REQUIRED 

40 

C 


50 


INCLUDE ' COM./NOLIST' 

60 

C 


70 


PRTEST = .FALSE. 

80 

C 


90 

C GET 

APPROPRIATE LIMITS FOR REGULAR 

100 

C 


110 


IF ( LCONT ) THEN 

120 


LB = 13 

130 


LE = 15 

140 


I = IDAIO 

150 


ELSE 

160 


LB = 1 

170 


LE = 5 

180 


I = ISTEP 

190 


ENDIF 

200 

C 


210 


DO 10 L = LB, LE, 2 

220 


J = I - I PC ( L , IAPC ) 

230 


K = IPC ( L+l , IAPC ) 

240 


IF ( ( J/K ) *K . EQ. J .AND. J 

250 

10 

CONTINUE 

260 

C 


270 


RETURN 

6528B 


END 


.TRUE. 
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SUBROUTINE MOVIE ( VAR , NX , IAPC , 

20 

C 


30 

C WRITES FILE FOR LATER LINEPL OR MOVI 

40 

C 


50 


INCLUDE ' COM. /NOLIST' 

60 

C 


70 


DIMENSION VAR ( NX , 1 ) 

80 

c 


90 

C OUTPUT STREAM 

100 

C 


110 


IS = 40 + IAPC 

120 

c 


130 

C IF 

I STD IS ZERO AND 11 IS NEGATIVE C 

140 

C OPEN NEW FILE AND WRITE HEADER 

150 

C 


160 


IF ( I STD .NE. 0) GO TO 90 

170 


IF (11 .GT. 999 ) GO TO 89 

180 


IF (11 .GT. 0 ) GO TO 90 

190 

c 


200 

C CORRECT SIGN OF 11 = IPC(7,IAPC) 

210 

C 


220 


11 = - 11 

230 


I PC ( 7 , IAPC ) = 11 

240 

89 

CONTINUE 

250 

C 


260 

C I 

RANGE FOR DATA 

270 

C 


280 


IB = 1 

290 


IE = IB + ( 12-11 )/l3 

300 


NI = IE 

310 

C 


320 

C K 

RANGE FOR DATA 

330 

C 


340 


KB = 1 

350 


KE = KB + (K2-K1)/K3 

360 


NK = KE 

370 

C 


380 

C OPEN NEW FILE 

390 

C 


400 


CALL SQOPN ( I S , 3 ) 

410 

c 

- 

420 

C WRITE HEADER 

430 

C 


440 


WRITE (IS) DESCR 

450 


WRITE (IS) LTI TLE ( IAPC ) 

460 


1 , I B , I E , NI 

470 


1 , KB , KE , NK 

480 


1 , Z L , ZR , YB , YT 

490 

c 


500 


GO TO 100 

510 

c 


520 

c OPEN EXISTING FILE FOR WRITING AT T 

530 

C 


540 

90 

CALL SQOPN ( I S , 2 ) 

550 


DO 91 1=1,9999 

560 

91 

READ (IS, END = 9 2 ) 

570 

92 

CONTINUE 

580 


IF (IMACH . EQ. 2) BACKSPACE I 
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590 C 

600 C WRITE ISTEP, TIME AND DATA 
610 C 

620 100 CONTINUE 

630 C 

640 WRITE (IS) I STEP , TTIME 

650 WRITE (IS) ( (VAR( I,K) ,1=11,12,13) ,K=K1,K2,K3) 

660 C 

670 C CLOSE FILE 
680 C 

690 CLOSE (UNIT-IS) 

700 C 
710 
720 


RETURN 

END 
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SUBROUTINE INIT0 

20 

C 



30 

C OPEN 

RESULT FILES, FOR EACH CASE. 

40 

C READ 

INPUT AND WRITE HEADINGS, FOR EACH CASE. STOP AT END. 

50 

C 



60 


INCLUDE 

' COM. /NOLIST' 

70 

C 



80 

C 


READ INPUT 

90 

C 


- 

100 


IOSTAT 

= 0 

110 

C 



120 

C THIS 

READ SKIPS THE SOS PAGE MARKER BETWEEN PAGES OF INPUT 

130 

C 



140 


IF ( ICASE .GT. 1 ) READ (5,230, END=201 , I OSTAT= IOSTAT ) 

150 

230 

FORMAT 

( ) 

160 

231 

FORMAT 

( 5X , A/ / / 

170 


1 

T7,7X,F10.6,T27,8X,F10.6 

180 


1 

,T47,7X,F10.6,T67,8X,F10.6 

190 


1 

,T87,8X,F13.6,T110,8X,F10. 6/ 

200 


1 

T7 ,7X, F10 .6 ,T27 , 8X,F10.6 

210 


1 

,T47,7X,F10 .6,T67,8X,F10.6 

220 


1 

,T87,8X,F13 .6,T110,8X,F10.6/ 

230 


1 

T7,7X,F10.6,T27,8X,F10.6 

240 


1 

,T47 , 7X, F10 .6,T67 , 8X, F10.6 

250 


1 

,T87,8X,F13.6,T110,8X,F10. 6/ 

260 


1 

, T27 , 8X, F10 . 6 

270 


1 

,T47,7X,F10.6,T67,8X,F10.6 

280 


1 

,T87,8X,F13 .6,T110,8X,F10.6/ 

290 


1 

, T8 7 , 8X , F13 . 6/ ) 

300 

232 

FORMAT 

(/// 

310 


1 

(T3,A12,T18,A20,T38,I4,T42,0P,F12.6,1P,7E10.2) ) 

320 

233 

FORMAT 

(// 

330 


1 

T2 ,7X, I5,T20,6X,L2,T36,5X,L2/ 

340 


1 

T2,7X,F8.3,T20,6X,F7.3/ 

350 


1 

T2,7X,F8.3,T20,6X,F7.3,T36,5X,F6.3 

360 


1 

,T51,8X,F6.3,T71,7X,L2,T84,7X,L2 

370 


1 

,T97,7X,F6.3,T114,7X,F6.3/ 

380 


1 

T2 ,7X, F8 . 3 , T20 , 6X, F7 . 3 ,T36, 5X,F6 . 3 

390 


1 

,T51,8X,F6.3,T71,7X,L2,T84,7X,L2 

400 


1 

,T97,7X,F6.3,T114,7X,F6.3/ 

410 


1 

T2,7X,F8.3,T20-,6X,F7.3,T36,5X,F6.3 

420 


1 

,T51 ,8X,F6 . 3,T71,7X,L2,T84,7X,L2 

430 


1 

,T97,7X,F6 :3,T114,7X,F6.3/ 

440 


1 

T2,7X,F8.3,T20,6X,F7.3,T36,5X,F6.3 

450 


1 

,T51,8X,I6,T71 ,7X,I3,T84,7X,I3 

460 


1 

,T97,7X,F6.3,T114,7X,F6.3) 

470 

235 

FORMAT 

(//// 

480 


1 

T4,7X,I5,T18,7X,I5 

490 


1 

, T50 , 8X, 14 , T66 , 8X, 15 

500 


1 

,T90,7X,I3,T105,6X,I3,8X,I3/ 

510 


1 

,T66 , 8X, F4 .1 ,T80 , 6X,F6 .2 ,T93 ,6X,F6 .2 

520 


1 

,T118,I3/// 

530 


1 

(2X,A8,I2,I8,I6,2(I10,I6),2X,2(3X,3I4),2(I8,I6: 

540 

C 



550 

C CIN 

REPLACES 

THESE LINES PRl , etc., BY THE FILES: 

560 

C PROBl , PROB2 

, METHl , METH2, AND OUTP.BC 

570 

C WHICH CONTAIN CONTINUATION LINES FOR I/O STATEMENTS IN INIT0 

580 

C AND 

FOR COMMON BLOCKS IN COMO TO MAKE THE INCLUDED FILE COM. 


,F6.1 ) ) 
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590 

600 

610 

620 

630 

640 

650 

660 

670 

680 

690 

700 

710 

720 

730 

740 

750 

760 

770 

780 

790 

800 

810 

oon 

u u 

830 

840 

850 

860 

870 

880 

890 

900 

910 

920 

930 

940 

950 

960 

970 

980 

990 

1000 

1010 

1020 

1030 

1040 

1050 

-1 A ^ 

iUOU 

1070 

1080 

1090 

1100 
^ 1 1 A 

mu 

1120 

1130 

1140 

1150 

1160 


C 

*PRl 


*PR2 

*MEl 

*ME2 

*OUT 


READ ( 5,231 ,END=200,ERR=1 40, IOSTAT=IOSTAT ) DESCR , 

READ ( 5,232 , END=14 0 , ERR=14 0 , IOSTAT=IOSTAT ) 

1 ( CMATPR ( I MAT) , CUNITS ( IMAT ) , MATPRT ( I MAT ) , 

1 ( PRPMAT ( K , I MAT ) , K= 1 , NPRCON ) 

1 , IMAT=1 , NMATPR ) 

READ ( 5,233 , END=140 , ERR=140 , IOSTAT=IOSTAT ) 


READ ( 5,235, END=1 4 0 , ERR=1 4 0 , IOSTAT=IOSTAT ) 

1 ,( STITLE(I), IDUM, (IPC(J,I), J = 1,16), ACONT(I), 


140 


C PRINT PREVIOUS RESULT FILE, UNDER NCOPY CONTROL. 

C KEEP RESULT FILE, FOR CONTOUR RUN. 

C LCONT IS .TRUE. FOR CONTOUR. 

C 

CONTINUE 

IF (ICASE .GT. 1) THEN 

IF ( .NOT. LCONT ) THEN 

IF (NCOPY .GE. 2) THEN 

CLOSE ( 6 , STATUS= ' PRINT ' ) 

ELSE IF (NCOPY . EQ . 1) THEN 

CLOSE ( 6 , STATUS= ' PRINT/DELETE ' ) 

ELSE 

CLOSE ( 6 , STATUS= ' KEEP ' ) 

ENDIF 


ELSE 

ENDIF 


CLOSE ( 6 , STATUS='KEEP' ) 


ENDIF 


C OPEN NEW RESULT FILE. 

C 

IF (LCONT .AND. IMACH . EQ . 2) THEN 

OPEN ( 6 , FI LE= ' NUL ' , STATUS= ' NEW' ) 

ELSE 

OPEN ( 6 , FI LE= ' PRN ' 

1 , STATUS= ' NEW RECL=160 , SHARED , FORM= ' FORMATTED ' ) 

ENDIF 
C 

C WRITE HEADING PAGE, EVEN IF THERE WAS AN ERROR. 

C 

C GET TEXT FOR DATE AND TIME 


TV r T r\7\nr>rpTM / 7 T T M C \ 

v_ j_; j_j unx xx i-x \ J / 


c GET NTYPE 

c 

TEXPRG ( 1 ) 
TEXPRG ( 2 ) 
TEXPRG ( 3 ) 
TEXPRG ( 4 ) 
C 

NTYPE = 1 


'TEMPERATURE SOLUTION' 

'TEMPERATURE AND CONCENTRATION' 
'TEMPERATURE AND FLOW' 

'TEMPERATURE, CONCENTRATION AND FLOW' 


IF (LU) NTYPE = 3 
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1170 


IF (LC) NTYPE = NTYPE + 1 

1180 

C 



1190 

C WRITE 

HEADER 

FOR SUMMARY PAGE 

1200 

C 



1210 


IF ( LCONT .AND. IMACH .EQ. 2) GO TO 160 

1220 


I PAGE = 

= MIN( I CASE -1,1) 

1230 


WRITE 

(16,162) IPAGE, TEXPRG ( NTYPE ) , I CASE , DESCR 

1240 


1 

, NR , NZ , NRA, NZS , JTIME 

1250 

162 

FORMAT 

( 11 ,A40 , ' CASE' , 13 , 4X,A30 , 4X 

1260 


1 

,I3,3( ' , ' ,I3),4X,A) 

1270 

C 



1280 

C WRITE 

HEADER 

PAGE ON STREAM 6 

1290 

C 



1300 


WRITE 

(6,139) TEXPRG ( NTYPE ) 

1310 


1 

, ICASE, NR , NZ , NRA, NZS , JTIME 

1320 

139 

FORMAT 

( '1' ,A,12X, 'CASE ',13 

1330 


1 

, 12X, 'MESH' , 13 , 3 ( ' , ' ,13) ,12X,A/) 

1340 

C 



1350 

C 



1360 

C CIN REPLACES 

THESE LINES PR1 , etc., BY THE FILES: 

1370 

C PROBl 

, PROB2, METH1 , METH2 , AND OUTP.BC 

1380 

C WHICH 

CONTAIN CONTINUATION LINES FOR I/O STATEMENTS IN INIT0 

1390 

C AND FOR COMMON BLOCKS IN COMO TO MAKE THE INCLUDED FILE COM. 

1400 

C 



1410 

C 



1420 

141 

WRITE 

(6,131) DESCR, 

1430 

*PRl 



1440 


WRITE 

(6,132) 

1450 


1 

( CMATPR ( IMAT ) , CUNI TS ( IMAT ) , MATPRT ( IMAT ) , 

1460 


1 

( PRPMAT ( K , I MAT ) ,K=l,NPRCON) 

1470 


1 

, IMAT=1 , NMATPR ) 

1480 

*PR2 



1490 


WRITE 

(6,133) 

1500 

*MEl 



1510 

*ME2 



1520 


WRITE 

(6,135) 

1530 

*OUT 



1540 


1 

,( STITLE(I), I, (IPC(J,I), J = 1,16), ACONT(I), I = 1,N 

1550 

C 



1560 


WRITE 

(6,136) 

1570 

131 

FORMAT ( 5X,A,T50 , ' ***PROBLEM PARAMETERS***'// 

1580 


1 

T7,'R MESH' ,T47,'Z MESH' 

1590 


1 

, T8 7 , ' EXTERNAL PARAMETERS ' / 

1600 


1 

T7 , ' RINS =',Fl0.6,T27,' DRINS =',F10.6 

1610 


1 

, T4 7 , ' ZT =' ,F10.6,T67,'DZT =',F10.6 

1620 


1 

, T87 , ' TTOP =' ,F13.6,T110, ' ZTTOP =',F10.6/ 

1630 


1 

T7 , ' RSAM = ' , Fl 0 . 6 , T27 , ' DRSAM =',F10.6 

16 4 0 


1 

, T4 7 , ' ZB = ' ,F1Q.6,T67,' DZB =',F10.6 

1650 


1 

, T8 7 , ' TBOT = ' ,F13.6,T110,' ZTBOT =',F10.6/ 

1660 


1 

T7 , ' RAMP = ' , F10 . 6 , T27 , ' DRAMPI =',F10.6 

1670 


1 

, T47 , ' ZINTI =' ,F10.6,T67, 'DZINTM =',F10.6 

1680 


1 

, T87 , ' GTERR = ' , Fl 3 . 6 , T110 , ' ZTBSC =',F10.6/ 

1690 


1 

, T27 , ' DRAMPO =',F10.6 

1700 


1 

, T4 7 , ' Z INTL «=' ,F10.6,T67,'DZINTS =',F10.6 

1710 


1 

, T87 , ' WAMP =' ,F13.6,T110, ' CTOP =',F10.6/ 

1720 


1 

,T87,'DENCBM = ' , F13 . 6/) 

1730 

132 

FORMAT ( T50 , ' ***MATERIAL PROPERTIES***'// 

1740 


1 

T3, ' PROPERTY' , T18 , 'UNITS ' ,T35 , ' CONTROL' , T46 , ' CONSTANTS'/ 
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1750 


1 

(T3,A12,T18 , A20,T38,I4,T42,0P,F12.6,1P,7E10.2) ) 

1760 

133 

FORMAT 

( /T50 , ' * * * METHOD PARAMETERS***'/ 

1770 


1 

T2, 'NSTEP =' ,I5,T20, ' LC = ' , L2 , T36 , ' LU =',L2/ 

1780 


1 

T2 , ' TAUS =' , F 8 . 3 , T 2 0 , ' TAUA = ' , F7 . 3 

1790 


1 

, T51 , ' ADVECTION' 

1800 


1 

,T71, 'FIXING CONTROLS' 

1810 


1 

,T97, 'FIXING AMPLITUDES'/ 

1820 


1 

T2 , ' TAUT = ' , F8 . 3 , T20 , ' PRT = ' , F7 . 3 , T36 , ' PZT =',F6.3 

1830 


1 

, T51 , ' TUPWND = ' , F6 . 3 , T71 , - FIXTR = ' , L2 , T8 4 , ' FIXTZ = ',L2 

1840 


1 

, T97 , ' BETTA =' , F6 . 3 , T114 , ' BETTD =',F6.3/ 

1850 


1 

T2 , ' TAUC «' ,F8.3,T20, 'PRC = ' , F7 . 3 , T36 , ' PZC = ' , F6 . 3 

1860 


1 

, T51 , ' CUPWND =' ,F6.3,T71, 'FIXCR = ' , L2 , T8 4 , ' FIXCZ =',L2 

1870 


1 

, T9 7 , ' BETCA =' ,F6 . 3 ,T114 , 'BETCD =',F6.3/ 

1880 


1 

T2 , ' TAUU = ' ,F8 . 3 ,T20 , ' PRU = ' , F7 . 3 , T36 , ' PZU * ' , F6 . 3 

1890 


1 

, T51 , ' UUPWND =' ,F6.3,T71, 'FIXUR = ' , L2 , T8 4 , ' FIXUZ =',L2 

1900 


1 

, T97 , ' BETUA =' , F6 . 3 ,T114 , 'BETUD =',F6.3/ 

1910 


1 

T2 , ' TAUF = ' , F8 . 3 , T2 0 , ' PRF = ' , F7 . 3 , T36 , ' BEF =',F6.3 

1920 


1 

, T51 , ' NUF = ' , I 6 , T71 , ' NTF = ' , I 3 , T8 4 , ' NCF = ',I3 

1930 


1 

, T97 , ' AQURTN= ' , F6 . 3 ,T114 , ' ATWLV =' ,F6 . 3 ) 

1940 

135 

FORMAT 

( /T50 , ' * *OUTPUT PARAMETERS***'// 

1950 


1 

T4, 'DIRECT ACCESS READ & WRITE SEGMENTS' 

1960 


1 

,T48, 'WRITE STEP BEGINNING & INCREMENT' 

1970 


1 

,T85, 'DIAGNOSTIC FREQUENCY CONTOUR LINES'/ 

1980 


1 

T4 , ' I SEGR =' ,I5,T18, 'ISEGW =',I5 

1990 


1 

, T50 , ' IBEGDA =' ,I4,T66, 'IINCDA =',I5 

2000 


1 

, T9 0 , ' NDIAG =' ,I3,T105, 'NCLP =',I3,' NCLI =',I3 

2010 


1 

T4 , ' ( 0 : ANALYTIC. -1: AFTER PRIOR CASE)', 

2020 


1 

T4 8 , ' ( - 1 MEANS NSTEP)' 

2030 


1 

, T6 6 , ' RSTRPL = ' , F4 . 1 ,T80 , ' ZBPL = ' , F6 . 2 , T9 3 , ' ZTPL =',F6.2 

2040 


1 

, T109 , ' NCOPIES =' , 13 

2050 


1 

/ T1 4 , ' I STEP BEGIN & INCREMENT FOR PRINTER DIAGNOSTICS' 

2060 


1 

,T6 9, 'RANGES FOR I AND K' 

2070 


1 

,T93 , 'PLOTTER IDAOUT BEGIN & INCREMENT' 

2080 


1 

/T3 ,' VARIABLE/I PHYSICAL CONTOUR' 

2090 


1 

, T32 ,' INTEGER CONTOUR ', T49 ,' PRINT NUMBERS' 

2100 


1 

,T66,'IB IE II KB KE KI ' 

2110 


1 

,T96, 'PHYSICAL' ,T110, 'INTEGER INCR'/ 

2120 


1 

(2X,A8, 12, 18, 16,2(110,16), 2X,2(3X, 314), 2(18, 16), F6.1 ) ) 

2130 

136 

FORMAT 

( 1H1 ) 

2140 

C 



2150 

C STOP ON ERROR OR NULL DATA - 

2160 

C 



2170 


IF ( IOSTAT .EQ. 0) GO TO 160 

2180 


WRITE 

(6,150) IOSTAT 

2190 


WRITE 

(*,150) IOSTAT 

2200 

150 

FORMAT 

(/' INPUT ERROR' ,16/) 

2210 


CALL STOPP ('INPUT ERROR OR NULL DATA% ' ) 

2220 

C 



2230 

C CONTINUE AFTER SUCESSFUL READ AND WRITE 

2240 

C 



2250 

160 

CONTINUE 

2260 

C 



2270 

M n » y M » ■* t •»*«% r ▼ n t-\ t - '* n t*l » TTT m P 

C n/-u\jDL l inu run unrauiiib 

2280 

c 

IDAOUT 

ZERO MEANS NSTEP 

2290 

c 

NDIAG 

ZERO MEANS UP TO 6 + 54 LINES 

2300 

c 



2310 


IDAOUT 

’ = IBEGDA 

2320 


IF (IDAOUT .EQ. -1) IDAOUT = NSTEP 
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2330 



IF ( NDIAG .EQ. 0) NDIAG = ( NSTEP - 2 )/( NLPP -NLMA- 6 - 4 ) + 1 


2340 



IF (NDIAG .LE. 0) NDIAG = 1 


2350 

C 


1 


2360 

C 

DIRECT ACCESS I/O SET UP HANDLED AS ENTRY TO INIT2, FOR CONVENIENT CHA 


2370 

C 




2380 



CALL SNREC 


2390 

C 




2400 

C 

z 

PLOT LIMITS AND DEFAULT CALCULATIONS 


2410 

C 


- 


2420 



IF ( ZBPL .EQ. 0) ZBPL = ZTBOT - RAMP 


2430 



ZBPL = MAX ( Z B P L , Z B ) 


2440 



IF ( ZTPL .EQ. 0) ZTPL = ZTTOP + RAMP 


2450 



ZTPL = MIN ( ZTPL , ZT ) 


2460 

C 




2470 

C 

CORRECT THE RANGES FOR PRINTING NUMBERS. 


2480 

C 




2490 



DO 100 IAPC = 1, NAPC 


2500 

C 




2510 



IF (IAPC .LE. 5) THEN 


2520 



IPC( 8, IAPC) = MIN ( I PC ( 8 , IAPC ) , NRCP2 ) 


2530 



IPC ( 1 1 , IAPC ) = MIN( IPC( 11 , IAPC) ,NZCP2) 


2540 



ELSE IF (IAPC .LE. 11) THEN 


2550 



IPC( 8, IAPC) = MIN ( I PC ( 8 , IAPC) ,NRP2 ) 


2560 



IPC ( 11 , IAPC ) = MIN( IPC( 11 , IAPC) , 1 ) 


2570 



ELSE IF (IAPC .GE. 14 .AND. IAPC .LE. 15) THEN 


2580 



IPC( 8 , IAPC ) = MIN ( IPC ( 8 , IAPC ) , NRPl ) 


2590 



I PC (11, IAPC ) = MIN(IPC(11/ IAPC ) , NZP1 ) 


2600 



ELSE 


2610 



IPC( 8 , IAPC ) = MIN( IPC ( 8 , IAPC ) , NRP2 ) 


2620 



IPC (11, IAPC ) = MIN( IPC( 11 , IAPC) ,NZP2 ) 


2630 



ENDIF 


2640 

C 




2650 

100 

CONTINUE 


2660 

C 




2670 

C 

PRODUCE MATERIAL PROPERTY DIAGNOSTICS 


2680 

C 




2690 



CALL PROPD 


2700 



IF (LC .AND. CTOP .NE. 0) CALL PROPDI 

.{ 

2710 

C 




2720 



RETURN 

■J 

2730 

C 


- 


2740 

C 

NO MORE DATA. USE SETUP FOR CASE 1, TO WRITE SETP.DAT 

4 

3 

2750 

C 




2760 

200 

IF ( ICASE .EQ. 1 ) THEN 


2770 



IF (IMACH .EQ. 2) THEN 


2780 



OPEN( 6 , FILE= ' . .\SETP.DAT' , STATUS= ' NEW' ) 


2790 



GO TO 141 


2800 



ELSE 


2810 



GO TO 140 


2820 



ENDIF 


2830 



ENDIF 


2840 

C 




2850 

201 

CALL STOPP ('END OF DATA% ' ) 


2860 

C 




2870 



END 

4 
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SUBROUTINE SMATPR 

20 

C 




30 

C SET 

MATERIAL PROPERTIES 

40 

C 




50 



INCLUDE 'COM. /NOLIST' 

60 

C 




70 

C SET 

MATERIAL PROPERTIES AS TEMPERATURE AND CONCENTRATION POWER SERIES 

80 

C 




90 



CALL 

PROPT ( CP , DT , T , C , NRCP2 , 1 , NRPl ,1 , NZPl , PRPMAT (1,1) 

100 



1 

, MATPRT ( 1 ) ) 

110 



CALL 

PROPT ( CP , DT , T , C , NRCP2 , 1 , NRPl , NZP2 , NZCP2 , PRPMAT (1,2) 

120 



1 

, MATPRT ( 2 ) ) 

130 



CALL 

PROPT ( CP , DT , T , C , NRCP2 ,NRP2 ,NRCP2 , 1 ,NZCP2 , PRPMAT ( 1 , 3 ) 

140 



1 

, MATPRT ( 3 ) ) 

150 

C 




160 



CALL 

PROPT ( COND , DT , T , C , NRCP2 , 1 , NRPl , 1 , NZPl , PRPMAT (1,4) 

170 



1 

, MATPRT ( 4 ) ) 

180 



CALL 

PROPT ( COND , DT, T , C , NRCP2 , 1 , NRPl , NZP2 , NZCP2 , PRPMAT (1,5) 

190 



1 

, MATPRT ( 5 ) ) 

200 



CALL 

PROPT ( COND , DT , T , C ,NRCP2 , NRP2 ,NRCP2 , 1 , NZCP2 , PRPMAT (1,6) 

210 



i 

, MATPRT ( 6 ) ) 

220 

c 




230 

c 

LATENT HEAT AT INTERFACE 

240 

c 




250 



IF ( MATPRT ( 7 ) . GT . 0) THEN 

260 




CALL PROP IN ( HEATLAT,DHLDT, PRPMAT ( 1 , 7 ) , MATPRT ( 7 ) , TINTH , NR 

270 



ELSE 


280 




CALL PROP IN (HEATLAT,DHLDC, PRPMAT (1,7) , MATPRT ( 7 ) , CINTMH , N 

290 




DO 90 I = 1, NRP2 

300 

90 



DHLDT(I) = DHLDC(I) * DCMDT(I) 

310 



ENDIF 

320 

C 




330 

C 

ADDITIONAL 

INTERFACE PROPERTIES, FUNCTIONS OF T AND C 

340 

C 




350 



CALL 

PROPT ( CDINTM, DT, TI NTH, CINTMH, NRP2,1, NRPl, 1,1, PRPMAT (1,4) 

360 



i 

, MATPRT ( 4 ) ) 

370 

C 




380 



CALL 

PROPT ( CPINTM , DT , TINTH , CINTMH, NRP2 , 1 , NRPl ,1,1, PRPMAT (1,1) 

| 390 



1 

, MATPRT ( 1 ) ) 

• 400 

C 




{ 410 



CALL 

PROPT ( CDINTC , DT , T-INTH , CINTCH , NRP2 , 1 , NRPl ,1,1, PRPMAT (1,5) 

* 420 



1 

, MATPRT ( 5) ) 

] 430 

C 




440 



CALL 

PROPT ( CPINTC,DT, TINTH, CINTCH, NRP2,1 , NRPl , 1 , 1 , PRPMAT ( 1 , 2 ) 

450 



1 

, MATPRT ( 2 ) ) 

460 

c 




470 



CALL 

PROPT ( DINTH ,DT , TINTH , CINTMH , NRP2 , 1 ,NRPl ,1,1, PRPMAT ( 1,11) 

480 



1 

, MATPRT ( 11 ) ) 

490 

c 




500 

c 

FINAL GROUP OF MELT PROPERTIES 

510 

c 




520 



IF ( 

. NOT . LU ) 

530 



1 

CALL PROPT ( BUOY , DT , T , C ,NRP2 , 1 ,NRP2 , 1 ,NZP2 , PRPMAT ( 1 , 10 ) 

540 



1 

, MATPRT ( 10 ) ) 

550 



IF ( LC) CALL PROPT( DIFF ,DT,T,C,NRP2 , 1 ,NRP2 , 1 ,NZP2 , PRPMAT ( 1,11) 

560 



i 

, MATPRT ( 11 ) ) 

570 



IF (LU) CALL PR0PT(VISC,DT,T,C,NRP2,1,NRP2,1,NZP2,PRPMAT(1,12) 

580 



1 

, MATPRT ( 12))' 
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590 

C 


600 


CALL PRNT ( CP , NRCP2 , 4 ) 

610 


CALL PRNT ( COND , NRCP2 , 5 ) 

620 

C 


630 


IF (.NOT.LU) CALL PRNT ( BUOY , NRP2 , 18 ) 

640 


IF (LC) CALL PRNT ( DI FF , NRP2 , 19 ) 

650 


IF (LU) CALL PRNT ( VI SC , NRP2 , 20 ) 

660 

C 


670 


RETURN 

680 

C 


65690 


END 
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150 

160 

170 

180 

190 

200 

210 

220 

230 

240 

250 

260 

270 

280 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 

390 

400 

410 

420 

430 

440 

6559B 


C 

C 

C 


C 

C 

C 

C 

C 

C 

C 

c 

c 


SUBROUTINE GTMCM ( TMELTA , CMELTA, CCRYSA) 

GET TMELTA FROM CCRYSA, AND CMELTA FROM TMELTA, FOR INIT2 AND PROPDI . 
INCLUDE ' COM. /NOLIST' 

NNEWT =10 
TMELTA FROM CCRYSA 

IF (MATPRT(9) .GT. 0) THEN 

INITIAL APPROXIMATION 
TMELTA = ( CCRYSA- PRPMAT (1,9) )/PRPMAT (2,9) 

NEWTON ITERATION TO CORRECT TMELTA 
DO 1 I NEWT = 1, NNEWT 

CALL PROPIN (CX,DCDT, PRPMAT (1,9) , MATPRT ( 9 ) , TMELTA , 1 ) 
TMELTA = TMELTA - ( CX - CCRYSA ) /DCDT 


C 

C 

c 


ELSE 
ENDIF 

CMELTA FROM TMELTA 


CALL PROPIN ( TMELTA, DTDC , PRPMAT ( 1,9) , MATPRT ( 9 ) , CCRYSA, 1 ) 


IF ( MATPRT ( 8 ) . GT . 0) THEN 

CALL PROPIN ( CMELTA, DMDT, PRPMAT ( 1,8) , MATPRT ( 8 ) , TMELTA, 1 ) 


ELSE 


C 

C 

c 

c 

c 

c 


2 

C 

C 


INITIAL APPROXIMATION 
CMELTA = ( TMELTA- PRPMAT( 1 , 8 ) )/PRPMAT( 2 , 8 ) 

NEWTON ITERATION TO CORRECT CMELTA 
DO 2 INEWT = 1 , NNEWT 

CALL PROPIN (TT, DTDC, PRPMAT( 1,8) , MATPRT ( 8 ) , CMELTA, 1) 
CMELTA = CMELTA - ( TT- TMELTA) /DTDC 


ENDIF 

RETURN 

END 
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150 
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180 

190 

200 

210 

220 

230 

240 

250 

260 

270 

280 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


SUBROUT I NE PROPT ( PR , WK , TT , CX , ID , IB , IE , KB , KE , PM , MP ) 

C 

C SET MATERIAL PROPERTY AS A TEMPERATURE AND CONCENTRATION POWER SERIES 
C 

PARAMETER ( MCS = 7) 

INCLUDE ' COM. /NOLI ST' 

C 

DIMENSION PR( ID, 1 ) , PM(NPRCON) 

DIMENSION WK( ID, 1 ) ,TT(NRCP2 , 1 ) ,CX£NRP2 , 1 ) 

DIMENSION NTS ( MCS ) 

INTEGER *4 MP , MPT, MTEN 
C 

C USE ONLY LAST DIGIT IN NO CONCENTRATION CASE 
C 

IF (.NOT. LC) MP « MOD ( MP ,10) 

C 

C ONLY SET CONSTANT FUNCTIONS ONCE 
C 

IF (I STEP .GT. 0 .AND. MP . EQ . 1 ) RETURN 


C 

c 

c 

c 

c 

c 

c 

c 


1 

c 


c 

c 

c 


PROCESS DECIMAL DIGITS OF MP TO GET RANGE OF POLYNOMIAL TERMS 

124 MEANS THERE ARE 4 POWERS OF T (i.e. a + bT + CTT + dTTT ) 

2 POWERS OF T MULTIPLYING C (i.e. C(e + fT) 

1 POWERS OF T MULTIPLYING C * C (i.e. CCg) 

- IN THAT ORDER 

SUM OF DIGITS MUST BE LESS THAN NPRCON 

MPT = MP 
NPC = 0 
NCS = MCS 

DO 1 M = MCS, 1, -1 

MTEN = 10 ** (M-l) 

NTS ( M ) = MPT / MTEN 

IF ( NTS ( M ) .EQ. 0) NCS = M - 1 

NPC = NPC + NTS ( M ) 

MPT = MPT - NTS ( M ) * MTEN 

IF (NPC .GT. NPRCON) CALL STOPP ('PROPT. NPC . GT . NPRCON% 
IF (MPT .NE. 0 ) CALL STOPP ('PROPT. MP WRONG% ' ) 

INITIALIZE TEMPERATURE POLYNOMIAL FOR HIGHEST C POWER 


DO 10 K = KB, KE 
DO 10 I = IB, IE 
10 PR ( I , K ) = PH (NPC) 

C 

C DOWNWARD LOOP FOR HIGHEST TEMPERATURE POLYNOMIAL EVALUATION 
C 


DO 20 IP = NTS ( NCS ) - 1 , 1, -1 

NPC = NPC - 1 
DO 20 K = KB, KE 
DO 20 I = IB, IE 

20 PR ( I , K ) = PM ( NPC ) + TT ( I , K ) * PR(I,K) 

C 

C LOOP DOWN THROUGH LOWER POWERS OF C 
C 

DO 60 M = NCS -1 , 1 , * 1 

NPC = NPC - 1 


) 


) 
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590 C 

600 C INITIALIZE TEMPERATURE POLYNOMIAL 
610 C 

620 DO 30 K = KB, KE 

630 DO 30 I = IB, IE 

640 30 WK ( I , K ) = PM(NPC) 

650 C 

660 C DOWNWARD LOOP FOR TEMPERATURE POLYNOMIAL EVALUATION 
670 C 

680 DO 40 IP = NTS ( M ) - 1 , 1, -1 

690 NPC = NPC - 1 

700 DO 40 K = KB, KE 

710 DO 40 I = IB, IE 

720 40 WK ( I , K ) = PM ( NPC ) + TT ( I , K ) * WK(I,K) 

730 C 

740 C UPDATE THE PROPERTY FOR THIS C POWER 
750 C 

760 DO 60 K = KB, KE 

770 DO 60 I = IB, IE 

780 60 PR ( I , K ) = WK ( I , K ) + CX(I,K) * PR(I,K) 

790 C 

800 RETURN 

810 C 

820 END 


4 


MIPS4$DRA3 : [ ROBERTS .BS ] PPl . ; 1 


18-SEP-1986 19:45 


Page 1 


10 

20 

30 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 

210 

220 

230 

240 

250 

260 

270 

280 

290 

300 

310 

320 

6533B 


SUBROUTINE PROPIN ( PR , PRD , PM , MP , X , NC ) 

C 

C SET MATERIAL PROPERTY PR AT INTERFACE AS A POWER SERIES IN X 
C SET MATERIAL PROPERTY DERIVATIVE PRD AT INTERFACE 
C 

INCLUDE 'COM. /NOLIST' 

C 

DIMENSION PR(NC) ,PM(NPRCON) ,X(NC) ,PRD(NC) 

INTEGER *4 MP 
C 

MPA = ABS(MP) 

IF (MPA .GT. NPRCON ) CALL STOPP ('PROPIN. MPA WRONG% ' ) 

C 

C ONLY SET CONSTANT FUNCTIONS ONCE 
C 

IF (ISTEP .GT. 0 .AND. MPA .EQ. 1 ) RETURN 
C 

C INITIALIZE POLYNOMIAL 
C 

DO 10 I = 1, NC 

PRD ( I ) = PM(MPA) * (MPA-1) 

10 PR ( I ) = PM (MPA) 

C 

C DOWNWARD LOOP FOR POLYNOMIAL EVALUATION 
C 

DO 20 IP = MPA-1, 1, -1 
DO 20 I = 1, NC 

IF (IP .GT. 1) PRD ( I ) = PM (IP) * (IP-1) + X ( I ) * PRD(I) 
20 PR ( I ) « PM ( IP ) + X(I) * PR ( I ) 

C 

RETURN 

C 


END 
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SUBROUTINE PROPD 


C 

C MATERIAL PROPERTIES DIAGNOSTICS OVER TEMPERATURE RANGE, FOR FIXED C 
C 

INCLUDE ' COM. /NOLIST' 

C 

PARAMETER (M=ll) 

COMMON PD(M) , WK(M) 

C 

C INITIALIZE TEMPERATURES 
C 

DO 1 I = 1, M 
C ( I , 1 ) = CTOP 

1 T ( I , 1 ) = TBOT + ( TTOP - TBOT ) * ( I - 1 . ) / (M-l.) 

C 

WRITE (6,5) 

5 FORMAT (//T30, 'MATERIAL PROPERTIES OVER THE TEMPERATURE RANGE, 

1 , ' FOR FIXED C = CTOP' ) 


C 

WRITE ( 6 , 3 )' TEMPERATURE deg C ' , ( T ( I , 1 ) , I = 1 , M ) 

C 

C LOOP OVER PROPERTIES 
C 

DO 2 IP = 1, NMATPR 

IF (IP .GE. 7 .AND. IP . LE. 9) GO TO 2 

CALL PROPT (PD,WK,T,C,M,1,M,1,1, PRPMAT ( 1 , I P ) , MATPRT (IP)) 
WRITE (6,3) CMATPR (IP), CUN ITS (IP) , PD 

2 CONTINUE 
C 

3 FORMAT ( /IX , A , A/1 2X , 1P,11E11.3) 

C 

RETURN 

END 
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SUBROUTINE PROPDI 
C 

C INTERFACE PROPERTIES DIAGNOSTICS OVER C RANGE FROM 0 TO 2*CTOP 
C OR TO 2 *CMELT IF IT IS LARGER. 

C 

INCLUDE ' COM./NOLIST' 

C 

PARAMETER (N=ll) 

COMMON PD ( M ) , WK(M), CD(M), TD(M). 

C 

C NOT IF CTOP IS ZERO 
C 

IF (CTOP . EQ. 0) RETURN 
C 

C GET TMELT AND CMELT 
C 

CALL GTMCM( TMELT, CMELT, CTOP) 

C 

C ROUND 
C 


C 

C 

C 

1 

C 

5 

C 

C 


CTP = ROUND ( MAX ( CTOP , CMELT ) ) 

INITIALIZE C 

DO 1 I = 1, M 

CD ( I ) = CTP * 2. * (1-1.) / (M-l.) 

WRITE (6,5) 

FORMAT(//T30 ,' INTERFACE PROPERTIES OVER THE ' 
1 , ' CONCENTRATION RANGE') 

WRITE ( 6 , 3 )' CONCENTRATION' , ' ' , ( CD ( I ) , 1=1 , M ) 

NNEWT =10 


C 

C LOOP OVER PROPERTIES 
C 

DO 2 IP = 9, 8, -1 

IF ( MATPRT ( IP ) .GT. 0) THEN 
C 

c INITIAL APPROXIMATION 

C 

DO 6 1=1, M 

6 TD ( I ) = ( CD ( I ) - PRPMAT ( 1 , IP ) )/PRPMAT ( 2 , IP ) 

C 

C NEWTON ITERATION 

C 

DO 4 I NEWT = 1 , NNEWT 

CALL PROPIN ( PD, WK, PRPMAT ( 1 , IP) , MATPRT ( IP) , TD , M ) 
DO 4 I = 1 , M 

4 TD ( I ) = TD ( I ) - ( PD ( I ) - CD ( I ) ) /WK ( I ) 

ELSE 

CALL PROPIN ( TD ,WK , PRPMAT( 1 , IP) , MATPRT ( IP) ,CD,M) 

ENDIF 

WRITE (6,3) CMATPR ( IP),' deg C' , TD 

2 CONTINUE 
C 

3 FORMAT ( /IX , A , A/1 2X ,1P,11E11.3) 
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IF ( MATPRT ( 7 ) .GT. 0) THEN 

CALL PROP IN ( PD , WK , PRPMAT ( 1,7) , MATPRT ( 7 ) , TD , M ) 

ELSE 

CALL PROP IN ( PD, WK, PRPMAT (1,7) , MATPRT ( 7 ) , CD , M ) 

END IF 

WRITE (6,3) CMATPR ( 7 ) ,CUNITS(7) , PD 

RETURN 

END 
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SUBROUTINE SINTPR 
C 

C SET INTERFACE PROPERTIES 
C 

INCLUDE 'COM. /NOLIST' 

C 

C EQUATION OF STATE FOR INTERFACE. FOUR DISTINCT CASES. 

C T, CM, CC ARE ALL INITIALIZED IN INIT0 AND UPDATED IN TFSTEP 
C THIS SECTION RECOMPUTES 2 OF THEM TO BE -CONS I STENT WITH THE THIRD 
C THE DERIVATIVES DCMDT AND DCCDT ARE REQUIRED FOR TFSTEP 
C 

IF ( MATPRT ( 8 ) . GT . 0) THEN 

IF ( MATPRT ( 9 ) .GT. 0) THEN 

CALL PROPIN ( CINTMH , DCMDT , PRPMAT (1,8), MATPRT ( 8 ) , T 
CALL PROPIN ( CINTCH , DCCDT , PRPMAT (1,9), MATPRT ( 9 ) ,T 

ELSE 

CALL PROPIN (TINTH,DTDCC, PRPMAT ( 1,9 ) , MATPRT ( 9 ) ,CI 
CALL PROPIN ( CINTMH , DCMDT , PRPMAT (1,8), MATPRT ( 8 ) , T 
DO 10 I = 1, NRP2 

10 DCCDT ( I ) = 1 . /DTDCC ( I ) 

ENDIF 


20 


C 

C 

C 


30 


40 


ELSE 

IF ( MATPRT ( 9 ) .GT. 0) THEN 

CALL PROPIN ( TINTH , DTDCM , PRPMAT (1,8) , MA.TPRT ( 8 ) ,CI 
CALL PROPIN(CINTCH,DCCDT,PRPMAT(l,9) ,MATPRT(9) ,T 
DO 20 I = 1, NRP2 
DCMDT(I) = 1 . /DTDCM ( I ) 

ELSE 

CALL PROPIN ( TINTH , DTDCC , PRPMAT (1,9) , MATPRT ( 9 ) ,CI 
NEWTON ITERATION TO CORRECT CM 
DO 30 INEWT = 1, 2 

CALL PROPIN (WK1, DTDCM, PRPMAT (1,8) , MATPRT ( 8 ) ,CINT 
DO 30 I = 1, NRP2 

CINTMH ( I ) = CINTMH(I) - ( WKl ( I ) - TINTH ( I ) ) / DTDC 

DO 40 I = 1, NRP2 
DCMDT ( I ) = 1 . /DTDCM ( I ) 

DCCDT ( I ) = 1 ./DTDCC ( I ) 

ENDIF 

ENDIF - • 


C APPLY 
C 


SYMMETRY AT AXIS, AND EXTRAPOLATE AT AMPOULE. 
TINTH ( 1 ) = TINTH ( 2 ) 

TINTH(NRP2) = TINTH ( NRPl ) * 2 - TINTH ( NR ) 
CINTMH(l) = CINTMH ( 2 ) 

CINTMH(NRP2) = CINTMH ( NRPl ) *2 - CINTMH (NR) 

CINTCH ( 1 ) = CINTCH ( 2 ) 

CINTCH ( NRP2 ) = CINTCH( NRPl ) *2 - CINTCH ( NR ) 
DCMDT ( 1 ) = DCMDT ( 2 ) 

DCMDT ( NRP2 ) = DCMDT ( NRPl )* 2 - DCMDT ( NR ) 

DCCDT ( 1 ) = DCCDT ( 2 ) 

DCCDT ( NRP2 ) = DCCDT ( NRPl )* 2 - DCCDT ( NR ) 

CALL PRNT ( TINTH , NRP2 , 8 ) 

IF (ISTEP .GT. 0) CALL PRNT ( DTINTH , NRP2 , 9 ) 
CALL PRNT ( CINTMH , NRP2 ,10) 

CALL PRNT (CINTCH, NRP2, 11 ) 
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590 RETURN 

600 END 
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SUBROUTINE TFSTEP 



20 

C 






30 

C 

UPDATES TEMPERATURE, CONCENTRATION, INTERFACE AND MESH. 

40 

C 






50 



INCLUDE 'COM. /NOLIST' 



60 

C 






70 

C 






80 

C 

SET 

DIAG 




90 

C 

INITIALIZE 

BOUNDARY OUTWARD FLUX DIAGNOSTICS 


100 

C 

INITIALIZE 

MEANS AND INTEGRAL 



110 

C 






120 



DIAG 

= • ( I STEP/ND I AG *ND I AG .EQ. ISTEP 

) 


130 



1 

.OR. ( ISTEP .EQ. NSTEP ) 



140 

C 






150 



IF (DIAG) THEN 



160 




FRITE = 0. 



170 




FTOP = 0 



180 




FBOT = 0 



190 




FINT = 0 



200 

c 






210 




XINT = 0 



220 




XTOP = 0 



230 

c 






240 




TUPM = 0 



250 




CUPM = 0 



260 



END IF 



270 

c 






280 

c 

NUF 

LOGIC 

TO DO UA SETUP AND DECOMPOSITION 



290 

c 






300 



J = 

ISTEP - 1 



310 



NF 4 

* MAX ( 1 , NUF/4 ) 



320 



NF2 

= NF4 * 2 



330 



LUF 

= LU .AND. ( ( J/NUF *NUF . EQ . J) 

.OR 

- 

340 



1 

(ISEGR .EQ. 0 .AND. 



350 



1 

( (J/NF4*NF4 .EQ. J .AND. J . 

LT. 

NUF-NF4) .OR. 

360 



1 

(J/NF2*NF2 .EQ. J .AND. J . 

LT. 

3 *NUF - NF2 ) 

370 



1 

) ) ) 



380 

c 






390 

c 

NCF 

LOGIC 

TO DO CA SETUP AND DECOMPOSITION 



400 

c 






410 



J = 

ISTEP - 1 - • 



420 



NF4 

= MAX ( 1 , NCF/4 ) . 



430 



NF2 

= NF4 * 2 



440 



LCF 

= LC .AND. ( ( J/NCF*NCF .EQ. J) 

.OP 

■ • 

450 



1 

(ISEGR .EQ. 0 .AND. 



460 



1 

( ( J /NF 4 *NF 4 .EQ. J .AND. J . 

LT. 

NCF - NF 4 ) .OR. 

470 



1 

( J /NF 2 *NF2 .EQ. J .AND. J . 

LT. 

3 *NCF - NF2 ) 

480 



1 

) ) ) 



490 

c 






500 

c 

NTF 

LOGIC 

TO DO TA SETUP AND DECOMPOSITION 



510 

c 






520 



J = 

ISTEP - 1 



530 



NF 4 

= MAX ( 1 , NTF / 4 ) 



540 



NF2 

= NF4 * 2 



550 



LTF 

= ( J/NTF*NTF .EQ. J) .OR. 



560 



1 

(ISEGR .EQ. 0 .AND. 



570 



1 

( (J/NF4*NF4 .EQ. J .AND. J . 

. LT. 

NTF-NF4) .OR 

580 



1 

(J/NF2*NF2 .EQ. J .AND. J . 

.LT. 

3 *NTF - NF2 ) 
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590 


1 ) ) 


600 

C 



610 

C LLF 

MEANS DO LEQ SETUP AND DECOMPOSITION 


620 

C 



630 


LLF = LTF .OR. LCF 


640 

C 



650 

C GET 

EXPLICIT RIGHT HAND SIDES 


660 

C GET 

COEFFICIENTS FOR CRANK - NI COLSON INVERSION 


670 

C 

- 


680 

C 



690 

C 

FLUXES AT TOP BOUNDARY 


700 

C 



710 


CALL TFZ ( 1 ) 


720 

C 



730 

C 

MAIN SWEEP DOWN THRU 

LAYERS 

740 

C 



750 


DO 100 K = 2, NZCPl 


760 

C 



770 

C INITIALIZE USING PRECALCULATED FLUXES ABOVE 


780 

C 



790 


DO 5 I = 2 , NRCPl 


800 

5 

DT ( I , K ) = TFZHW(I) 


810 

C 



820 


IF (LC .AND. K .LE. NZPl ) THEN 


830 


DO 6 1=2, NRPl 


840 

6 

DC ( I , K ) = CFZHW(I) 


850 


ENDIF 


860 

C 



870 


CALL TFZ(K) 


880 


CALL TFR(K) 


890 

C 



900 

C GET 

DT, THE EXPLICIT RIGHT HAND SIDE TIMES THE 

CELL VOLUME 

910 

C 

I.E. - DI.FR - DK.FZ 


920 

C 



930 

1 

FORMAT (/IX, A, (Til ,1P,12E10.2) ) 


940 

C 

WRITE (6,1) ' TFRWH ' , ( TFRWH ( I ) , 1=1 , NRPl ) 


950 

C 

WRITE (6,1) ' TFZHW ' , ( TFZHW( I ) , 1=1 , NRPl ) 


960 

C 



970 


DO 40 I = 2, NRCPl 


980 

40 

DT ( I , K ) = DT ( I , K ) - TFRWH ( I ) + TFRWH(I-l) 

- TFZHW(I) 

990 

C 

- 


1000 


IF (LC .AND. K .LE. NZPl) THEN 


1010 


DO 50 I = 2, NRPl 


1020 

50 

DC ( I , K ) = DC ( I , K ) - CFRWH(I) + CFRWH(I-l) - CFZHW- 

1030 


ENDIF 


1040 

C 



1050 

C CORRECT TFZH'W ON INTERFACE TO CRYSTAL VALUE, FOR NEXT K VALUE. 

1060 

C TFZ 

PREVIOUSLY CALLED TCINT 


1070 

C 



1080 


IF (K .EQ. NZPl) THEN 


1090 


DO 90 I = 2, NRPl 


1100 

90 

TFZHW ( I ) = TFZC(I) 


1110 


ENDIF 


1120 

C 



1130 

100 

CONTINUE 


1140 

C 



1150 

C 



1160 

C DO 

CRANK-NICOLSON INVERSION 
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1170 

C 




1180 


CALL CNINV 



1190 

C 




1200 

C 




1210 

C UPDATE 

TINTH(I), CINTMH(I), AND CINTCH(I), MAKE 

THEM CONSISTENT, 

1220 

C 




1230 


IF (LC) THEN 



1240 


DO 130 1=2, NRP 1 



1250 


TINTH(I) = TINTH(I) + DTINTH ( I ) 



1260 


CINTMH(I) = CINTMH ( I ) + DTINTH ( I ) 

■k 

DCMDT ( I ) 

1270 

130 

CINTCH(I) = CINTCH ( I ) + DTINTH ( I ) 

* 

DCCDT ( I ) 

1280 

C 




1290 


CALL SINTPR 



1300 

C 




1310 


ENDIF 



1320 

C 




1330 

C 




1340 

C UPDATE 

; MESH AND CALL PRNT 



1350 

C 




1360 


DO 115 I = 2, NRP 1 



1370 

115 

FINTH(I) = FINTH(I) + DFINTH(I) 



1380 

C 




1390 


CALL MESH 



1400 

C 




1410 

C UPDATE TEMPERATURE AND APPLY TEMPERATURE BOUNDARY 

CONDITIONS. 

1420 

C 




1430 


DO 110 K = 2, NZCPl 



1440 


DO 110 1=2, NRCPl 



1450 


T ( I , K ) = T ( I , K ) + DT ( I , K ) 



1460 

110 

CONTINUE 



1470 

c 




1480 


CALL TBC 



1490 

c 




1500 


CALL TDIAG 



1510 

c 




1520 

C TEMPERATURE OUTPUT 



1530 

C 




1540 


CALL PRNT ( T , NRCP2 , 2 ) 



1550 


CALL PRNT ( DT , NRCP 2 , 3 ) 



1560 

c 




1570 

C UPDATE CONCENTRATION AND APP-LY CONCENTRATION BOUNDARY CONDITIONS 

1580 

c 




1590 


IF (LC) THEN 



1600 

c 




1610 


DO 120 K = 2, NZPl 



1620 


DO 120 1=2, NRPl 



1630 

120 

C ( I , K ) = C ( I , K ) + DC ( I , K ) 



1640 

C 




1650 


CALL CBC 



1660 

C 




1670 


CALL CDIAG 



1680 

C 




1690 


CALL PRNT (C,NRP2,12) 



1700 


CALL PRNT ( DC , NRP2 ,13) 



1710 

C 




1720 


ENDIF 



1730 

c 




1740 

c 
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1750 C DIRECT ACCESS OUTPUT HANDLED AS ENTRY TO INIT2 FOR CONVENIENT CHANGE 
1760 C 

1770 CALL DDAOUT 

1780 C 

1790 RETURN 

65 80B END 
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SUBROUTINE CNINV 
C 

C SOLVES SIMULTANEOUS LINEAR SYSTEM FOR dT, dC IN INTERIORS 
C AND dF, dT, dC, dCC ON INTERFACE 
C 

INCLUDE 'COM. /NOLIST' 

C 

C FOR dT AND dC IN THE MELT: 

C Cp(VdT/dt - rdrBkDkT . eta . df/dt ) + DiCi + DkCk = - (EXPLICIT TERMS) (st 
C Ci = ( - RDDi + RGBi + REBi kDk ) dT + RFDrdF 
C Ck = ( - ZDDk + ZGBk + ZEBikDi)]dT + ZFDrdF 
C 

C Di IS THE CENTRAL DIFFERENCE OPERATOR IN THE I DIRECTION 
C Bi IS THE DOUBLED AVERAGING OPERATOR IN THE I DIRECTION 
C 

C DrdF USES THE REPRESENTATION OF DFDR IN MESH, WITH DIDRW ( I ) . DidF 
C AND APPROPRIATE AVERAGING OR EXTRAPOLATION. 

C 

C THERE ARE SPECIAL REPRESENTATIONS NEAR THE EXTERIOR AND INTERIOR 
C BOUNDARIES, ESPECIALLY FOR THE SLOPING MESH TERMS E AND F. 

C 

C FOR dT IN CRYSTAL, RC- IS ZERO 

C FOR dT IN AMPOULE, RG = RE = RF = ZE = ZF = 0 
C 

C INTERFACE CONDITIONS 

C EXPRESSIONS FOR 2 T FLUXES AND ONE C FLUX IN THE k DIRECTION 
C dC AND dCC ARE MULTIPLES OF dT 

C 2 CONSERVATION EQUATIONS, CORRESPONDING TO THE 2 UNKNOWNS dT AND dF 
C EXPRESSION FOR CONSTANT dF IN AMPOULE 
C 

C THERMAL FLUX DOUNDARY CONDITION 

C HEAT INCREASE AT INTERFACE (LATENT HEAT RELEASE AND DIFFUSION) = 0 
C = r. dr. Lathe at. ( WAMP+ df/dt ) . DENCBM + Diffusion from melt and crystal 
C Diffusion has explicit terms, and implicit terms like those above. 

C TCINT SETS THE EXPLICIT TERMS AND THE ARRAYS TZD, TZE, TZF, TZG, FOR 
C THE MELT AND TZICD, TZICE, TZICF, TZICG FOR THE CRYSTAL. 

C 

C SOLUTE FLUX DOUNDARY CONDITION 

C SOLUTE INCREASE AT INTERFACE (DIFFERENCE OF FLUXES ON TWO SIDES) = 0 
C = r .dr . (WAMP+df/dt ) .DENCBM. ( Cm-Cc ) + Diffusion from melt 
C Diffusion has explicit terms-, and implicit terms like those above. 

C TCINT SETS THE EXPLICIT TERMS AND THE ARRAYS CZD, CZE, CZF , CZG. 

C 

C WE HAVE TRIED 3 METHODS: 

C 

C 1. APPROXIMATE SOLUTION AS 2 GENERALIZED TRIDIAGONAL DIVISIONS, IN THE 
C TWO COORDINATE DIRECTIONS, WITH TREATMENT FOR dF 

C 

C 2. ITERATIVE SOLUTION WITH 2 GENERALIZED TRIDIAGONAL DIVISIONS AT EACH 
C 

C 3. DIRECT GAUSSIAN ELIMINATION, USING THE BANDED MATRIX STRUCTURE 
C 

CALL CNINVG 
C 

RETURN 

END 
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10 



SUBROUTINE TBC 

20 

C 



30 

C SET 

UP AND APPLY BOUNDARY CONDITIONS TO TEMPERATURE AND DT . 

40 

C CALLED EVERY STEP- NOTE THAT THE SET UP MUST BE REPEATED SINCE THE MES 

50 

c 



60 



INCLUDE 'COM. /NOLIST' 

70 

c 



80 

C GET 

INVERSE MESH SPACING AT ZTBOT AND ZTTOP 

90 

C 


- 

100 



DKDZB = 1.E5 

110 



DO 10 K = NZCPl , 1, -1 

120 



IF (ZAW(K) .LE. ZTBOT) DKDZT = DKDZAH ( K+l ) 

130 



IF (ZAW(K) .LE. ZTTOP) DKDZB = DKDZAH ( K+l ) 

140 

10 


CONTINUE 

150 

C 



160 

C SET 

CONSTANT AND MULTIPLIER ARRAYS FOR RIGHT 

170 

C 

ZTBSC = 0 : ADIABATIC SECTION, UNSMOOTHED 

180 

C 

ZTBSC POS : ADIABATIC SECTION, SMOOTHED OVER ZTBSC TIMES MESH SPACI 

190 

C 

ZTBSC = -1 : LINEAR INTERPOLATION 

200 

C 



210 



IF (ZTBSC .EQ. 0) THEN 

220 



DO 20 K = 1, NZCP2 

230 



IF (ZAH(K) .LT. ZTBOT) THEN 

240 



TRBC(K) = 2 * TBOT 

250 



TRBM(K) = -1 

260 



ELSE IF (ZAH(K) . GT . ZTTOP) THEN 

270 



TRBC(K) = 2 * TTOP 

280 



TRBM ( K ) = - 1 

290 



ELSE 

300 



TRBC(K) = 0 

310 



TRBM(K) = 1 

320 



ENDIF 

330 

20 


CONTINUE 

340 



ELSE IF (ZTBSC . EQ . -1) THEN 

350 



DO 25 K = 1, NZCP2 

360 



IF (ZAH(K) .GT. ZTBOT) THEN 

370 



TRBC(K) = 2 * TBOT 

380 



TRBM(K) = -1 

390 



ELSE IF (ZAH(K) .LT. ZTTOP) THEN 

400 



TRBC(K) = 2 * TTOP 

410 



TRBM(K-) = -1 

420 



ELSE 

430 



TRBC(K) = 2. * (TTOP + (TBOT - TTOP) 

440 



1 * (ZAH(K) - ZTTOP) / (ZTBOT - ZTTOP) ) 

450 



TRBM(K) = -1 

460 



ENDIF 

470 

25 


CONTINUE 

480 



ELSE IF (ZTBSC .GT. 0) THEN- 

490 



DO 30 K = 1, NZCP2 

500 



WBOT = (1 + TANH ( ( ZAH ( K ) - ZTBOT ) /ZTBSC* DKDZT ) ) 

510 



WTOP = (1 - TANH ( ( ZAH ( K ) - ZTTOP ) /ZTBSC* DKDZB) ) 

520 



TRBC(K) = WBOT * TBOT + WTOP * TTOP 

530 



TRBM(K) = (1. - WBOT - WTOP) 

540 

30 


CONTINUE 

550 



ELSE 

560 



CALL STOPP ('TBC. ZTBSC ILLEGAL% ' ) 

570 



ENDIF 

580 

C 
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590 

600 

610 

620 

630 

640 

650 

660 

670 

680 

690 

700 

710 

720 

730 

740 

750 

760 

770 

780 

790 

800 

810 

8 ^ n 
^ u 

830 

840 

850 

860 

870 

880 

890 

900 

910 

920 

930 

940 

6593B 


C 

C 

C 


5 


WRITE DIAGNOSTIC ARRAYS 

IF (ISTEP .EQ. 0) THEN 

WRITE (6,5) ' TRBC ' , TRBC 

WRITE (6,5) ' TRBM ' , TRBM 

WRITE (6, ' (/" TBC . ' ' , 

1 »'ZT, ZTTOP , ZTBOT , ZB, ZTBSC, DKDZT , DKDZB 

1 ZT, ZTTOP, ZTBOT, ZB, ZTBSC, DKDZT, DKDZB 

FORMAT ( //IX , A, T12 , 1P10E11 . 3 , :/(Tl2,lPlOEll 

ENDIF 


C 

C 

C DO 
C 


SIDES 

DO 50 K 


NZCP2 


C 

T ( 1 , K ) = T ( 2 , K ) 

T ( NRCP2 , K ) = T ( NRCPl , K ) * TRBM(K) + TRBC ( K ) 

C 

DT ( 1 , K ) = DT ( 2 , K ) 

DT ( NRCP2 , K ) = DT ( NRCPl , K ) * TRBM(K) 

50 CONTINUE 


n 

C DO ENDS 
C 

DO 60 I = 1, NRCP2 
C 

T ( I , 1) = 2 * TTOP - T(I, 2) 

T ( I , NZCP2 ) = 2 * TBOT - T(I,NZCPl) 
C 

DT ( I , 1) = - DT ( I , 2) 

DT ( I , NZCP2 ) = - DT ( I , NZCP 1 ) 

60 CONTINUE 

C 

RETURN 

END 


,9F9.3) ' ) 

) ) 
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10 



SUBROUTINE CBC 

20 

C 



30 

C 

APPLY 

CONCENTRATION BOUNDARY CONDITIONS 

40 

C 



50 



INCLUDE ' COM. /NOLIST' 

60 

C 



70 

C 

IMPOSED AT THE TOP AND BOTTOM 

80 

C 



90 



DO 2 I = 2, NRPl 

100 



DC ( I , NZP2 ) = - DC ( I , NZPl ) 

110 



C ( I , NZP2 ) = - C ( I , NZ P 1 ) + 2 * CINTMH ( : 

120 

C 



130 



CTMULT(I) = -1. 

140 



DC (1,1) = - DC (I, 2) 

150 

2 


C(I,1) = - C ( I , 2 ) + 2 * CTOP 

160 

C 



170 

C 

SYMMETRY AT THE LEFT AND EXTRAPOLATE AT RIGHT 

180 

C 

RIGHT 

VALUE IS USED ONLY FOR GRAPHICS 

190 

C 



200 



DO 1 K = 1, NZP2 

210 



DC ( NRP2 , K ) = DC ( NRP 1 , K ) * 2 - DC ( NR , K ) 

non 
^ ^ u 



C ( NRP2 , K ) = C ( NRPl , K ) * 2 - C(NR,K) 

230 



DC ( 1 , K ) = DC ( 2 , K ) 

240 

1 


C ( 1 , K ) = C ( 2 , K ) 

250 

C 



260 



RETURN 

270 



END 
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SUBROUTINE TFR(K) 

20 

C 


30 

C GET 

R TEMPERATURE AND CONCENTRATION FLUXES AT LEVEL K. 

40 

C SAVE ARRAYS FOR CRANK - NI COLSON INVERSION 

50 

C 


60 


INCLUDE 'COM. /NOLIST' 

70 

c 


80 

c 


90 

C DO 

AMPOULE 

100 

C 


110 


DO 100 I = NRP2, NRCPl 

120 


TDRWH(I) = ( COND ( I , K ) + COND(I+l,K)) * RB2DRW(I) * DZDKAH ( 

130 

100 

TFRWH(I) = - TDRWH(I) * (T(I+1,K) - T(I,K) ) 

140 

c 


150 

c 


160 

C DO 

SAMPLE 

170 

C 


180 

C 


190 

C ADVECTION FLUXES 

200 

C 


210 


IF (K . LE. NZPl ) THEN 

220 


DO 4 I = 2, NR 

230 


IF (LC) CGRWH(I) = ( - PSI ( I , K ) + PSI(I,K-1)) * 0. 

240 

4 

TGRWH(I) = ( - PSI(I,K) + PSI ( I , K - 1 ) ) 

250 


1 * ( CP( I , K)+CP( I+1,K) ) * 0.25 

260 


IB = NRPl 

270 


ELSE 

280 


IB = 2 

290 


ENDIF 

300 

C 


310 


DO 8 I = IB, NRPl 

320 

8 

TGRWH ( I ) = 0 . 

330 

C 


340 

C 


350 

C 


360 

C DO 

SAMPLE SEPARATELY FOR TEMPERATURE AND CONCENTRATION COMBINED 

370 

C 


380 

C 


390 


IF (K .LE. NZPl .AND. LC ) THEN 

400 

C 


410 

C 

- 

420 

C 


430 


DO 20 I = 2, NR 

440 


E = COND ( I , K ) + COND( 1+1 , K ) 

450 


F = DI FF ( I , K ) + DI FF ( I + 1 , K ) 

460 


TERWH(I) = E * ETAH(K) 

470 


CERWH(I) = F * ETAH(K) 

480 


DF = RB2DRW ( I ) * (DZTDKH(K) + DETDKH ( K ) *RFINTW( I ) ) 

490 


TDRWH(I) = E * DF 

500 


CDRWH(I) = F * DF 

510 

20 

CONTINUE 

520 

C 


530 

C CORRECT FOR UPWIND DIFFERENCE 

540 

C 


550 


IF (LU .AND. TUPWND .NE. 0) THEN 

560 


DO 40 I = 2, NR 

570 


RAT = AB S ( TGRWH ( I ) * TUPWND/TDRWH ( I ) ) 

580 


TUPM = MAX ( TUPM , RAT ) 
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590 

40 


TDRWH(I) = TDRWH(I) * MAX (1., RAT) 

600 


ENDIF 


610 

C 



620 


IF (LU 

.AND. CUPWND .NE. 0) THEN 

630 



DO 50 I = 2, NR 

640 



RAC = ABS ( CGRWH ( I ) *CUPWND/CDRWH ( I ) ) 

650 



CUPM = MAX ( CUPM , RAC ) 

660 

50 


CDRWH(I) = CDRWH(I) * MAX (1., RAC) 

670 


ENDIF 

- 

680 

C 



690 

C SLOPING MESH 

TERM D2T = 4DKBIKT MODIFIED NEXT TO INTERFACE 

700 

C 



710 


IF (K . 

EQ. NZPl ) THEN 

720 



DO 51 I = 2, NR 

730 



D2T ( I ) = 2. * ( TINTH ( 1+1 ) + TINTH(I)) 

740 


1 

- T ( I +1 , NZ ) - T ( I , NZ ) 

750 


1 

- T ( 1+1 , NZPl ) - T ( I , NZPl ) 

760 

51 


D2C ( I ) = 2. * ( CINTMH ( 1+1 ) + CINTMH ( I ) ) 

770 


1 

- C(I+1,NZ) - C ( I , NZ ) 

780 


1 

- C ( 1+1 , NZPl ) - C ( I , NZPl ) 

790 


ELSE 


800 



DO 60 I = 2, NR 

810 



D2T ( I ) = T ( I +1 , K+l ) + T ( I , K+l ) 

820 


1 

- T( 1 + 1 , K - 1 ) - T ( I , K - 1 ) 

830 

60 


D2C ( I ) = C ( I +1 , K + l ) + C ( I , K+l ) 

840 


1 

- C ( 1+1 / K - 1 ) - C ( I , K - 1 ) 

850 


ENDIF 


860 

C 



870 

C 



880 

C 



890 


ELSE IF (K .GE. NZP2 .OR. (.NOT. LC ) ) THEN 

900 

C 



910 

c 



920 

c 



930 

C SAMPLE SECTION WITH TEMPERATURE BUT NO CONCENTRATION 

940 

C 



950 


DO 25 : 

I = 2, NR 

960 


E = COND ( I , K ) + COND ( 1+1 , K ) 

970 


TERWH(I) = E * ETAH(K) 

980 


DF = RB2DRW ( I ) * (DZTDKH(K) + DETDKH ( K ) *RFINTW ( I ) ) 

990 


TDRWH(I) = E * DF 

1000 

25 

CONTINUE 

1010 

C 



1020 

C - 

CORRECT FOR 

UPWIND DIFFERENCE 

1030 

C 



1040 


IF ( LU 

.AND. TUPWND .NE. 0 .AND. K .LE. NZPl) THEN 

1050 



DO 47 I = 2, NR 

1060 



RAT = ABS ( TGRWK ( I ) * TUPWND/TDRWH ( I ) ) 

1070 



TUPM = MAX( TUPM, RAT) 

1080 

47 


TDRWH ( I ) = TDRWH ( I ) * MAX ( 1 . , RAT ) 

1090 


ENDIF 


1100 

C 



1110 

C 



1120 

C 

SLOPING MESH 

TERM D2T = 4DKBIKT MODIFIED NEXT TO INTERFACE 

1130 

C 



1140 


IF ( K 

.EQ. NZPl) THEN 

1150 



DO 55 I = 2, NR 

1160 

55 


D2T(I) = 2. * ( TINTH ( 1+1 ) + TINTH ( I ) ) 
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1170 



1 

- T ( 1+1 , NZ ) - T ( I , NZ ) 

1180 



1 

- T ( 1+1 , NZPl ) - T( I ,NZPl ) 

1190 



ELSE IF 

(K .EQ. NZP2) THEN 

1200 




DO 65 I = 2, NR 

1210 

65 



D2T ( I ) = T ( 1+1 , NZP2+1 ) + T ( I , NZP2+1 ) 

1220 



1 

+ T ( 1+1 , NZP2 ) + T(I,NZP2) 

1230 



1 

- 2. * ( TINTH ( 1+1 ) + TINTH(I)) 

1240 



ELSE 


1250 




DO 75 I = 2, NR 

1260 

75 



D2T(I) = T( 1+1 , K+l ) + T( I , K+l ) 

1270 



1 

- T ( 1 + 1 , K - 1 ) - T ( I , K - 1 ) 

1280 



ENDIF 


1290 

C 




1300 

C 




1310 

c 




1320 



END IF 


1330 

c 




1340 

c 

END 

IF K BLOCKS FOR INTERFACE AND MELT CONCENTRATION 

1350 

c 




1360 

c 




1370 

c 




1380 

r 




1390 

c 

DO SAMPLE BOUNDARY, FOR TEMPERATURE 

1400 

c 




1410 



TDRWH(NRPl) = RSAM * DZDKAH(K) * 2 

1420 



1 

* ( COND ( NRPl, K ) *DIDRW( NRPl) * COND ( NRP2 , K ) *DIDRAB ) 

1430 



1 

/ ( COND ( NRPl , K ) *DIDRW ( NRPl ) + COND ( NRP2 , K ) *DIDRAB ) 

1440 



TERWH(NRPl) = 2 * ( COND ( NRPl , K ) *ETAH ( K ) * COND ( NRP2 , K ) *DIDRAB ) 

1450 



1 

/ ( COND (NRPl , K ) *DIDRW ( NRPl ) + COND ( NRP2 , K ) *DIDRAB ) 

1460 

c 




1470 

c 

SLOPING MESH 

TERM D2T = 4DKBIKT MODIFIED NEXT TO INTERFACE 

1480 

c 




1490 



IF ( K . 

. EQ. NZPl) THEN 

1500 




D2T ( NRPl ) = 2 * (- T ( NRP2 , NZ ) - T(NRPl,NZ) 

1510 



1 

+ T ( NRP2 , NZPl ) + T ( NRPl , NZPl ) ) 

1520 



ELSE IF (K .EQ. NZP2 ) THEN 

1530 




D2T ( NRPl ) = 2 * ( T(NRP2 ,NZ+3 ) + T(NRPl,NZ+3) 

1540 



1 

- T ( NRP2 , NZP2 ) - T ( NRPl , NZP2 ) ) 

1550 



ELSE 


1560 




D2T ( NRPl ) = T ( NRP2 , K+l ) + T(NRPl,K+l) 

1570 



1 

- T ( NR-P2 , K - 1 ) - T ( NRPl , K - 1 ) 

1580 



ENDIF 


1590 

c 




1600 

c 




1610 

c 

GET 

CONCENTRATION FLUX 

1620 

c 




1630 



IF ( LC 

.AND. K .LE. NZPl) THEN 

1640 




DO 80 I = 2 , NR 

1650 

8 0 


CFRWH(I) = CGRWH(I) * (C(I+1,K) + C(I,K) ) 

1660 



1 

- CDRWH(I) * ( C ( 1+1 , K ) - C(I,K) ) 

1670 



1 

+ CERWH(I) * RDRF8H ( I ) * D2C(I) 

1680 



ENDIF 


1690 

c 




1700 

c 




1710 

c 

GET 

HEAT FLUX 

1720 

c 




1730 



DO 9 0 

1=2, NRPl 

1740 

90 

TFRWH(I) = TGRWH(I) * (T(I+1,K) + T(I,K) ) 
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1750 


1 - TDRWH(I) * (T(I+1,K) - T ( I , K ) ) 


1760 


1 + TERWH(I) * RDRF8H ( I ) * D2T(I) 


1770 

C 



1780 

C ZERO 

CONCENTRATION FLUX AT AXIS AND SAMPLE BOUNDARY 


1790 

C 



1800 


IF (LC) THEN 


1810 


CFRWH(l) = 0. 


1820 


CFRWH(NRPl) = 0. 


1830 


ENDIF 


1840 

C 



1850 

C SAVE 

THE COEFFICIENTS IF NECESSARY 


1860 

c 



1870 


BEFB8 = BEF/8 


1880 

c 



1890 


IF ( LTF ) THEN 


1900 


DO 110 1=2, NRCP1 


1910 

110 

TRD ( I , K ) = BETTD * TDRWH(I) 


1920 

c 



1930 


IF (K .LE. NZP1) THEN 


1940 


DO 113 I = 2, NRPl 


1950 

113 

TRG ( I , K ) = BETTA * TGRWH(I) 


1960 


ENDIF 


1970 

C 



1980 


DO 115 1=2, NRPl 


1990 


TRF ( I , K ) = BEFB8 * TERWH(I) * RW( I ) * D2T(I) 


2000 

115 

TRE ( I , K ) = BETTD * TERWH(I) * RDRF8H(I) 


2010 


ENDIF 


2020 

C 



2030 


IF ( LCF .AND. K . LE . NZPl ) THEN 


2040 


DO 70 I = 2, NR 


2050 


CRD ( I , K ) = BETCD * CDRWH(I) 


2060 


CRE ( I , K ) = BETCD * CERWH(I) * RDRF8H ( I ) 


2070 


CRF ( I , K ) = BEFB8 * CERWH(I) * RW(I) * D2C(I) 


2080 

70 

CRG ( I , K ) = BETCA * CGRWH(I) 


2090 


ENDIF 


2100 

C 



2110 

C SET 

AXIS FLUX 


2120 

C 



2130 


TFRWH(l) = 0. 


2140 

C 



2150 

C UPDATE RIGHT HEAT FLUX 


2160 

C 



2170 

C HEAT FLUXES ( cal/cm2/se c ) AND SOLUTE FLUXES (cc/cm2/sec = 

cm/sec ) 

2180 

C ARE 

OUTWARD FROM THE COMPUTATIONAL DOMAIN (NEGATIVE AT THE 

TOP) , 

2190 

C AND 

INTO THE INTERFACE, FOR HEAT, OR TO THE CRYSTAL, FOR SOLUTE. 

2200 

C 



2210 

C ADVECTIVE HEAT FLUX IS DEFINED AS CpT.U 


2220 

C 



2230 


FRITE = FRITE - TFRWH(NRCPl) 


2240 

c 



2250 


RETURN 


62386 


END 
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10 



SUBROUTINE TFZ(K) 

20 

C 



30 

C GET 

Z TEMPERATURE FLUXES AT LEVEL K, IN SAMPLE AND AMPOULE. 

40 

C GET 

Z CONCENTRATION FLUXES AT LEVEL K, IN MELT. 

50 

C GET 

COEFFICIENT ARRAYS FOR CNINV. 

60 

C 



70 



INCLUDE ' COM. /NOLIST' 

80 

C 



90 



BEFB8 = BEF/8 

100 

C 



110 

C 1 

DO AMPOULE 

120 

C 



130 



DO 70 I = NRP2, NRCPl 

140 



TGZ = - RDRWQH(I) * ( CP ( I , K ) +CP ( I , K+l ) ) 

150 



TDZHW(I) = ( COND ( I , K ) + COND(I,K+l)) * RDRB2H(I) * DKDZAW ( K ) 

160 



TFZHW(I) = - TDZHW(I) * (T(I,K+1) - T(I,K) ) 

170 



1 + TGZ * { T ( I , K+l ) + T( I , K ) ) 

180 



TZD ( I , K ) = BETTD * TDZHW(I) 

190 

70 


TZG ( I , K ) = BETTA * TGZ 

200 

C 



210 

C 

GET 

ADVECTION COEFFICIENTS IN THE SAMPLE 

220 

C 



230 



IF (K .LE. NZPl ) THEN 

240 



IF (LC) THEN 

250 



DO 3 I = 2, NRPl 

260 



CGZHW(I) = ( PSI ( I , K ) - PSI ( I - 1 , K ) ) * 0.5 

270 

3 


TGZHW(I) = ( PSI ( I , K ) * PSI ( I - 1 , K ) ) 

280 



1 * (CP(I,K)+CP(I,K+1) ) * 0.25 

290 



ELSE 

300 



DO 51 = 2, NRPl 

310 

5 


TGZHW(I) = ( PSI ( I , K ) - PSI ( I - 1 , K ) ) 

320 



1 * (CP( I ,K)+CP( I , K+l ) ) * 0.25 

330 



ENDIF 

340 



ELSE 

350 



DO 10 I = 2, NRPl 

360 

10 

TGZHW(I) = - RDRWQH(I) * ( CP ( I , K ) +CP ( I , K+l ) ) 

370 



ENDIF 

380 

C 



390 

C 



400 

C 

DO 

SAMPLE 

410 

C 


- 

420 

C 

SAMPLE SPLIT INTO INTERFACE , CONCENTRATION AND TEMPERATURE IN MELT 

430 

C 

AND 

TEMPERATURE IN BOTH OR JUST IN CRYSTAL. 

440 

c 



450 

c 



460 



IF (K .EQ. NZPl) THEN 

470 

c 



480 

c 



490 



CALL TCINT 

500 



RETURN 

510 

c 



520 

c 



530 



ELSE IF (K .LE. NZ .AND. LC ) THEN 

540 

c 



550 

c 



560 

c 



570 



DO 20 I = 2, NRPl 

580 



E = COND ( I , K ) + COND ( I , K+l ) 
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590 



F = DIFF(I,K) + DI FF ( I , K+l ) 

600 



TE2HW ( I ) 

= E * ETAW(K) 

610 



CEZHW ( I ) 

= F * ETAW(K) 

620 



DF = (RDRB2H(I) + ZDRFH ( I ) *ETA2W ( K ) ) 

630 



1 

/ (DZTDKW(K) + DETDKW ( K ) *RFINTH ( I ) ) 

640 



TDZHW ( I ) 

= E * DF 

650 



CDZ HW ( I ) 

= F * DF 

660 

20 


CONTINUE 


670 

C 



- 

680 

C CORRECT FOR UPWIND DIFFERENCE 

690 

C 




700 



IF (LU 

.AND. TUPWND .NE. 0) THEN 

710 




DO 40 I = 2, NRPl 

720 




RAT = ABS ( TGZHW ( I ) *TUPWND/TDZHW ( I ) ) 

730 




TUPM = MAX ( TUPM , RAT ) 

740 

40 



TDZHW ( I ) = TDZHW ( I ) * MAX(1.,RAT) 

750 



END IF 


760 

C 




770 



IF ( LU 

.AND. CUPWND .NE. 0) THEN 

780 




DO 50 I =2, NRPl 

790 




RAC = ABS ( CGZHW ( I ) *CUPWND/CDZHW ( I ) ) 

800 




rTIDM — MfY/ PllDM D1T\ 

u O i u — x ax x A \ \+> \j x. xx / x vA f 

810 

50 



CDZHW(I) = CDZHW(I) * MAX (1., RAC) 

820 



ENDIF 


830 

C 




840 

C 

SLOPING MESH TERM D2T = 4DIBIKT MODIFIED NEXT TO INTERFACE 

850 

c 




860 



DO 60 I 

= 2 , NR 

870 



D2T ( I ) = 

: T ( 1+1 , K+l ) + T ( 1+1 , K ) 

880 



1 

- T ( I - 1 , K+l ) - T ( I - 1 , K ) 

890 



D2C ( I ) = 

: C( 1+1 , K+l ) + C( 1+1 , K ) 

900 



1 

- C( I -1 , K+l ) - C( I -1 , K) 

910 

60 


CONTINUE 

920 



D2T ( NRPl 

.) = ( T ( NRPl , K+ 1 ) + T ( NRPl , K ) 

930 



1 

- T ( NR , K+l ) - T ( NR , K ) ) * 2 

940 



D2C ( NRPl ) = ( C ( NRPl , K+l ) + C(NRPl,K) 

950 



1 

- C ( NR , K+l ) - C ( NR , K ) ) * 2 

960 

C 




970 

C 

SAVE 

THE C COEFFICIENTS IF NECESSARY 

980 

C 




990 



IF ( LCF ) 

1 THEN 

1000 




DO 62 I = 2, NRPl 

1010 




CZD ( I , K ) = BETCD * CDZHW(I) 

1020 




CZE ( I , K ) = BETCD * CEZHW(I) * RDRF8H ( I ) 

1030 




CZ F ( I , K ) = BEFB8 * CEZHW(I) * RH(I) * D2C(I) 

1040 

62 



CZG ( I , K ) = BETCA * CGZHW(I) 

1050 



ENDIF 


1060 

C 




1070 

C 




1080 

C 




1090 



ELSE IF 

(K .GE. NZP2 .OR. (.NOT. LC) ) THEN 

1100 

C 




1110 

C 

T IN 

CRYSTAL, 

AND ALSO IN MELT FOR THE NO - CONCENTRATION CASE 

1120 

C 




1130 



DO 25 I 

= 2, NRPl 

1140 



E = COND ( I , K ) + COND ( I , K+ 1 ) 

1150 



TEZHW ( I 

) = E * ETAW(K) 

1160 



DF = ( RDRB2H ( I ) + ZDRFH ( I ) * ETA2W ( K ) ) 
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1170 
1180 
1190 
1200 
1210 
1220 
1230 
1240 
1250 
1260 
1270 
1280 
1290 
1300 
1310 
1320 
1330 
1340 
1350 
1360 
1370 
1380 
1390 
1400 
1410 
1420 
1430 
1440 
1450 
1460 
1470 
1480 
1490 
1500 
1510 
1520 
1530 
1540 
1550 
1560 
1570 
1580 
1590 
1600 
1610 
1620 
1630 
1640 
1650 
1660 
1670 
1680 
1690 
1700 
1710 
1720 
1730 
1 7df) 


1 / (DZTDKW(K) + DETDKW( K) *RFINTH( 1 ) ) 

TDZHW(I) = E * DF 
25 CONTINUE 

C 

C CORRECT FOR UPWIND DIFFERENCE 
C 

IF ( LU .AND. TUPWND .NE. 0 .AND. K . LE . NZ ) THEN 
DO 45 I = 2, NRP 1 

RAT = ABS ( TGZHW ( I ) *TUPWND/TDZHW ( I ) ) 

TUPM = MAX ( TUPM, RAT) 

45 TDZHW(I) = TDZHW(I) * MAX(1.,RAT) 

ENDIF 

C 

C 

C SLOPING MESH TERM D2T = 4DIBIKT MODIFIED NEXT TO INTERFACE 
C 

DO 65 I = 2, NR 

D2T(I) = T ( 1+1 , K+l ) + T ( 1+1 , K ) 

1 - T ( I - 1 , K + l ) - T ( I - 1 , K ) 

65 CONTINUE 

D2T ( NRPl ) = ( T ( NRPl ,K+1 ) + T(NRP1,K) 

1 - T ( NR , K + 1 ) - T ( NR , K ) ) * 2 

C 

C 

C 

ENDIF 

C 

C END IF K BLOCKS FOR SAMPLE 

C SAMPLE SPLIT INTO INTERFACE, CONCENTRATION AND TEMPERATURE IN MELT, 
C AND TEMPERATURE IN BOTH OR JUST IN CRYSTAL. 

C 

C 

C 

C 

C GET VERTICAL HEAT FLUXES IN SAMPLE 
C 

DO 75 I = 2, NRPl 

75 TFZHW(I) = TGZHW ( I ) * (T(I,K+1) + T(I,K) ) 

1 - TDZHW(I) * ( T ( I , K+l ) - T( I , K ) ) 

1 + TEZHW(I) * RDRF8H ( I ) * D2T(I) 

C 

C 

C GET CONCENTRATION FLUXES 
C 

IF ( LC .AND. K .LE. NZ ) THEN 
DO 77 I = 2, NRPl 

77 CFZHW(I) = CGZHW(I) * (C(I,K+1) + C(I,K) ) 

1 - CDZHW(I) * ( C ( I , K+l ) - C ( I , K ) ) 

1 + CEZHW(I) * RDRF8H ( I ) * D2C(I) 

ENDIF 

C 

C 

C SAVE THE TEMPERATURE COEFFICIENTS IF NECESSARY 
C 

IF ( LTF ) THEN 

DO 79 I = 2, NRPl 

TZD ( I , K ) = BETTD * TDZHW(I) 

TZE(I.K) = BETTD * TEZHW(I) * RDRF8H ( I ) 
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1750 



TZ F ( I , K ) = BEFB8 * TEZHW(I) * 

RH ( I ) * 

D2T( I ) 

1760 

79 


TZG ( I , K ) = BETTA * TGZHW(I) 



1770 



ENDIF 



1780 

C 





1790 

C 

GET 

TOP AND BOTTOM FLUX DIAGNOSTICS 



1800 

C 





1810 

C 

HEAT 

1 FLUXES ( cal/cm2/sec ) AND SOLUTE FLUXES 

(cc/cm2/sec = cm/sec 

1820 

C 

ARE 

OUTWARD FROM THE COMPUTATIONAL DOMAIN (NEGATIVE 

AT THE TOP) . 

1830 

C 


- 



1840 

C 

ADVECTIVE HEAT FLUX IS DEFINED AS CpT.U 



1850 

C 





1860 

C 

SOLUTE UNIT IS PRODUCT OF CONCENTRATION AND 

FLUID VOLUME. 

1870 

C 





1880 

C 

GET 

TOP FLUX DIAGNOSTICS 



1890 

C 





1900 



IF (K .EQ. 1) THEN 



1910 



DO 80 I = 2, NRCP1 



1920 

80 

FTOP = FTOP + TFZHW(I) 



1930 



IF (LC) THEN 



1940 



DO 85 I = 2, NRPl 



1950 

85 

XTOP = XTOP + CFZHW(I) 


1960 



ENDIF 



1970 



ENDIF 



1980 

C 





1990 

C 

GET 

BOTTOM FLUX DIAGNOSTIC 



2000 

C 





2010 



IF (K .EQ. NZCPl ) THEN 



2020 



DO 90 I = 2, NRCP1 



2030 

90 

FBOT = FBOT - TFZHW(I) 



2040 



ENDIF 



2050 

C 





2060 



RETURN 



63830 



END 
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10 



SUBROUTINE TCINT 

20 

C 



30 

C 

INTERFACE CONDITIONS FOR TEMPERATURE AND CONCENTRATION 

40 

C 



50 

C 

GET 

FLUXES TFZHW AND CFZHW ON MELT SIDE 

60 

C 


AND FLUX TFZC ON CRYSTAL SIDE, FOR TFSTEP . 

70 

C 

GET 

COEFFICIENT ARRAYS TZ%(I,NZPl) AND TZIC%(I) 

80 

C 


FOR CNINV DTSU AND DTSL EQUATIONS 

90 

C 

GET 

COEFFICIENT ARRAYS CZ%(I,NZPl) 

100 

C 



110 

C 

GET 

FLUX IMBALANCES DFTINT AND DFCINT FOR CORRECTION BY CNINV 

120 

C 

SET 

CORRESPONDING COEEFFI Cl ENT ARRAYS FOR CNINV 

130 

C 



140 



INCLUDE ' COM./NOLIST' 

150 

C 



160 



DO 10 I = 2, NRP 1 

170 

C 



180 



CGZ = ( PSI ( I , NZPl ) - PS I ( I - 1 , NZPl ) ) * 0.5 

190 



TGZ = ( PSI ( I , NZPl ) - PSI ( I - 1 ,NZPl ) ) * 0.5 * CPINTM(I) 

200 



TGC = - CPINTC(I) * 2. * RDRWQH ( I ) 

210 

C 



nn 

l* yj 



DINT2 = DINTH(I) * 2. 

230 



CDIM2 = CDINTM ( I ) * 2. 

240 



CDIC2 = CDINTC(I) * 2. 

250 

c 



260 

c 



270 



DFM = ( RDRB2H ( I ) + ZDRFH ( I ) ) 

28 0 



1 / ( DZTDKW( NZPl ) + DETDKW(NZPl ) *RFINTH( I ) ) 

290 



DFC = ( RDRB2H ( I ) + ZDRFH ( I ) ) 

300 



1 * DKDZTC / (1. + DEDZTC * RFINTH ( I ) ) 

310 

c 



320 



CDZ = DINT2 * DFM 

330 



TDZ = CDIM2 * DFM 

340 



TDC = CDIC2 * DFC 

350 

c 



360 



IF (I .EQ. NRP1 ) THEN 

370 



DT2 = 4 * (TINTH(I) - TINTH(I-l) ) 

380 



DC2 = 4 * (CINTMH(I) - CINTMH(I-l) ) 

390 



ELSE 

400 



DT2 * 2 * ( TINTH ( 1+1 ) - TINTH(I-l) ) 

410 



DC2 = 2 * ( CINTMH ( 1+1 ) - CINTMH(I-l) ) 

420 



ENDIF 

430 

c 


CFZ = DINT2 *DC2*RDRF8H( I ) - 2.*CDZ * (CINTMH(I)' - C(I,NZP1) ) 

440 



450 



TFZ = CDIM2 * DT2 * RDRF8H ( I ) - 2.*TDZ * ( TINTH ( I ) - T(I,NZPl) 

460 



TFC = CDIC2 * DT2 *RDRF8H ( I ) - 2.*TDC * (T(I,NZP2) - TINTH ( I ) ) 

470 

c 



480 



CFZHW(I) = 2. * CGZ * CINTMH(I) + CFZ 

490 



TFZHW ( I ) = 2. * TGZ * TINTH ( I ) + TFZ 

500 



TFZC ( I ) = 2. * TGC * TINTH ( I ) + TFC 

510 

c 



520 



BEFB8 = BEF/8 

530 

c 



540 



CZD ( I , NZPl ) = BETCD * CDZ 

550 



CZ E ( I , NZ P 1 ) = BETCD * DINT2 * RDRF8H(I) 

560 



CZF ( I , NZPl ) = BEFB 8 * DINT2 * RH(I) * DC2 

570 



CZG ( I , NZPl ) = BETCA * CGZ 

580 

c 




) 
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590 
600 
610 
620 
630 
640 
650 
660 
670 
680 
690 
700 
710 
720 
730 
740 
750 
760 
770 
780 
790 
800 
810 
820 
830 
840 
850 
860 
870 
880 
890 
900 
910 
920 
930 
940 
950 
960 
970 
980 
990 
1000 
1010 
1020 
1030 
1040 
1050 
1060 
1070 
1080 
1090 
1100 
1110 
1120 
1130 
1140 
1150 
1 1 60 


TZD ( I , NZPl ) = BETTD * TDZ 

TZE(I.NZPl) = BETTD * CDIM2 * RDRF8H ( I ) 

TZ F ( I , NZPl ) = BEFB8 * CDIM2 * RH(I) * DT2 
TZG ( I , NZPl ) = BETTA * TGZ 
C 

TZICD(I) = BETTD * TDC 

TZICE(I) = BETTD * CDIC2 * RDRF8H ( I ) 

TZICF(I) = BEFB8 * CDIC2 * RH(I) * DT2 
TZICG(I) = BETTA * TGC 
C 

C THERMAL FLUX DOUNDARY CONDITION 

C DTFINT = EXPLICIT HEAT INCREASE AT INTERFACE (LATENT HEAT RELEASE AND 
C = A . L . WAMP . DENCBM + "TM - TI" + "TC - TI" 

C = A. L. WAMP. DENCBM - TFZ + TFC (NOTE THAT D'S A 

C = - A . L . FDOT . DENCBM + IMPLICIT TEMPERATURE TERMS 

C = - A. L. FDOT. DENCBM + DM( DTM-DTI ) + DC(DTC-DTI) 

C 

RDRDEN = 2 . *RDRB2H( I )*DENCBM 
H = RDRDEN * HEATLAT ( I ) 

DTFINT ( I ) = H * WAMP - TFZ + TFC 
DFTINT ( I ) = - H * BTF(I) 


C SOLUTE MASS FLUX BOUNDARY CONDITION 

C DCFINT = EXPLICIT RATE OF INCREASE IN SOLUTE AT INTERFACE BY ADVECTION 
C = WAMP. RDR. DENCBM. ( CMI - CCI ) + "CM - CMI" 

C = WAMP. RDR. DENCBM. (CMI - CCI) - CFZ (NOTE THAT D IS 

C = - FDOT. RDR. DENCBM. (CMI - CCI) - IMPLICIT DT TERMS WITH WAMP + 

C = - FDOT. RDR. DENCBM. (CMI - CCI) - WAMP . RDR . DENCBM .( DCMDT - DCCCT ) . 

C 

DCFINT ( I ) = RDRDEN * (CINTMH(I) - CINTCH(I)) * WAMP - CFZ 

DFCINT ( I ) = - RDRDEN * (CINTMH(I) - CINTCH(I)) * BTF ( I ) 

DTCINT(I) = - RDRDEN * ( DCMDT ( I ) - DCCDT(I)) * WAMP 

C 

C INTERFACE FLUX DIAGNOSTICS 
C 

C HEAT FLUXES ( cal/cm2/sec ) AND SOLUTE FLUXES (cc/cm2/sec = cm/sec) 

C ARE OUTWARD FROM THE COMPUTATIONAL DOMAIN (NEGATIVE AT THE TOP), 

C AND INTO THE INTERFACE, FOR HEAT, OR TO THE CRYSTAL, FOR SOLUTE. 

C 

C ADVECTIVE HEAT FLUX IS DEFINED AS CpT.U 
C 

FINT = FINT - TFZHW(I) + TFZC(I) 

XINT = XINT - CFZHW(I) 

C 

10 CONTINUE 

C 

C DIAGNOSTICS 
C 

IF (ISTEP/1*1 . EQ . ISTEP .AND. ISTEP . LE . 20) THEN 
C WRITE ( 6 , ' ( / /A ,14/)') ' INTERFACE DIAGNOSTICS AT STEP' , ISTEP 

20 FORMAT ( /IX, A6, 4X, 1 P, 1 2E1 0. 2/(1 IX, 12E1 0.2) ) 

WRITE (6,20) ' CFZHW ' , ( CFZHW ( I ) , 1=2 , NRPl ) 

C WRITE (6,20) ' TFZHW ' , ( TFZHW ( I ) , 1=2 , NRPl ) 

C WRITE (6,20) 'TFZC' ,(TFZC(I) ,1 = 2, NRPl) 

C WRITE (6,20) 'CZD' ,(CZD(I, NZPl), 1 = 2, NRPl ) 

C WRITE (6,20) 'CZE' , (CZE(I, NZPl) ,1 = 2, NRPl) 

C WRITE (6,20) 'CZF' , (CZF(I, NZPl) ,1 = 2, NRPl) 

C WRITE (6,20) 'CZG' , (CZG( I ,NZPl) ,1 = 2, NRPl ) 
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1170 

C 

WRITE 

(6,20) 

1180 

C 

WRITE 

(6,20) 

1190 

C 

WRITE 

(6,20) 

1200 

C 

WRITE 

(6,20) 

1210 

C 

WRITE 

(6,20) 

1220 

C 

WRITE 

(6,20) 

1230 

C 

WRITE 

(6,20) 

1240 

C 

WRITE 

(6,20) 

1250 

C 

WRITE 

(6,20) 

1260 

C 

WRITE 

(6,20) 

1270 

C 

WRITE 

(6,20) 

1280 

C 

WRITE 

(6,20) 

1290 

C 

WRITE 

(6,20) 

1300 


ENDIF 


1310 

C 



1320 


RETURN 

1330 


END 



' TZD ' , ( TZD ( I , NZP1 ) , 1 = 2 ,NRPl ) 

' TZE ' , ( TZE ( I,NZPl) ,1 = 2 ,NRPl ) 

' TZF ' , ( TZF( I ,NZP1 ) , 1 = 2 ,NRP1 ) 

' TZG ' , ( TZG ( I , NZPl ) , 1 = 2 , NRPl ) 

' TZ I CD ' , ( TZ I CD ( I ) , I = 2, NRPl ) 

' TZICE ' , ( TZICE( I ) , 1 = 2 , NRPl ) 

' TZ I CF ' , ( TZ I CF ( I ) , 1=2, NRPl ) 

' TZICG' , (TZICG( I ) , 1 = 2, NRPl ) 

' DTFINT' , ( DTFINT( I ) , 1=2 , NRPl ) 
' DFTINT ' , ( D FT I NT ( I ) , 1 = 2 , NRPl ) 
' DC FI NT ' , ( DCF I NT ( I ) , 1=2 , NRPl ) 
' DFCINT ' , (DFCINT(I) ,1=2, NRPl) 
' DTCINT ' , (DTCINT(I) ,1=2, NRPl) 
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SUBROUTINE CNINVG 



20 

C 




30 

C 

SOLVES SIMULTANEOUS LINEAR SYSTEM FOR dT, dC IN INTERIORS 



40 

c 

AND dF, dT, dC, dCC ON INTERFACE 



50 

c 

USES BANDED STRUCTURE GAUSSIAN ELIMINATION 



60 

c 




70 


INCLUDE ' COM./ nolist ' 



80 

c 




90 

c 

CN% 1 SETS UP %A AND %F, AND DOES A BANDED DECOMPOSITION DOWN 

TO 

THE IN 

100 

c 

IT IS NOT REPEATED EVERY STEP 



110 

c 




120 

c 

CN%2 ELIMINATES D% EXCEPT NEXT TO THE INTERFACE, USING THE DECOMPOSED 

130 

c 




140 

c 

LEQ SETS UP AND SOLVES THE INTERFACE PROBLEM FOR THE CHANGES 

IN 

INTERF 

150 

c 

HEIGHT AND TEMPERATURE, AND IN T AND C NEXT TO THE INTERFACE 



160 

c 




170 

c 

CN% 3 SUBSTITUTES BACK TO OBTAIN D% AWAY FROM THE INTERFACE 



180 

c 




190 


IF ( LTF ) CALL CNTl 



200 


CALL CNT2 



210 


IF (LC) THEN 



220 


IF ( LCF ) CALL CNC1 



230 


CALL CNC2 



240 


CALL LEQ(NAI) 



250 


CALL CNC3 



260 


ELSE 



270 


CALL LEQ(NAIS) 



280 


END IF 



290 


CALL CNT3 



300 

c 




310 


RETURN 



65930 


END 
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SUBROUTINE CNCl 

20 

C 



30 

C SET 

UP 

AND L-U DECOMPOSE THE BANDED MATRIX FOR DC 

40 

C SET 

UP 

ROWS OF INTERFACE MATRIX 

50 

C ELIMINATE DC EXCEPT ADJACENT TO INTERFACE 

60 

C SET 

RIGHT HAND SIDE TERMS FOR INTERFACE MATRIX 

70 

C 



80 



INCLUDE ' COM. /NOLIST' 

90 

C 


- 

100 

C 



110 

C WRITE 

ARRAY CHARACTER DIAGNOSTICS 

120 

C 



130 



IF (ISTEP .EQ. 1) THEN 

140 

c 


CALL WAC ( CRD , NRP2 , NZPl , 2 , ' CRD% ' ) 

150 

c 


CALL WAC ( CRE , NRP2 , NZPl, 2, ' CRE% ' ) 

160 

c 


CALL WAC ( CRF , NRP2 , NZPl , 2 , ' CRF% ' ) 

170 

c 


CALL WAC ( CRG , NRP2 , NZPl , 2 , ' CRG% ' ) 

180 

c 


CALL WAC ( CZD , NRP2 , NZPl, 2, ' CZD% ' ) 

190 

c 


CALL WAC ( CZE , NRP2 , NZPl , 2 , 'CZE%' ) 

200 

c 


CALL WAC ( CZ F , NRP2 , NZPl , 2 , 'CZF%' ) 

210 

c 


CALL WAC(CZG,NRP2,NZP1,2,'CZG%’ ) 

220 



ENDIF 

230 

c 



240 

c 



250 

C CLEAR 

CF AND CA, THEN SET CA - DIAGONAL TO VBT 

260 

C 



270 



DO 17 K = 1, NZ 

280 



DO 17 I = 1, NR 

290 

C 



300 



DO 5 J = 1, NR 

310 

5 


CF( J,I,K) = 0 

320 

C 



330 



DO 10 J = 1, NCB 

340 

10 


CA ( J , I , K ) = 0 . 

350 

c 



360 



CA ( NRP2 , 1 , K ) = CVBTRH( 1 + 1 ) *CVBTZH( K+l ) 

370 



1 * ( l+RF INTH ( 1+1 ) *DEDZTH ( K+l ) ) 

380 

c 



390 

c DO 

MOVING -MESH TERMS, BOTH DC AND DF, IN CA AND CF . 

400 

c 



410 



CFF = - RDRB2H ( 1+1 ) * ETAH ( K+l ) * BTF(I+1) 

420 

C 



430 

C SPECIAL REPRESENTATIONS FOR DKC2 AND ITS CHANGE 

440 

C THE 

: REPRESENTATION NEXT TO THE INTERFACE INCLUDES CINTMH 

450 

C 



460 



DKC2 = C ( 1+1 , K+2 ) - C ( 1+1 , K ) 

470 

C 



480 



DO 16 KE = -1, 1, 2 

490 

C 



500 



IF (K .EQ. 1 .AND. KE . EQ . -1) THEN 

510 



RKE = - CTMULT ( I + 1 ) 

520 



KEE = 0 

530 



ELSE IF (K .EQ. NZ ) THEN 

540 



KEE = MIN ( KE , 0 ) 

550 



DKC2 = 2 * CINTMH ( 1 + 1 ) - (C(I + 1,K+1) + C(I + 1 

560 



CA ( NRP2+NR , I , K ) = 

570 



1 CA( NRP2+NR , I , K ) + CFF * BETCA * 2 * DFINTH 

580 



RKE = -1 
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600 
610 
620 
630 
640 
650 
660 
670 
680 
690 
700 
710 
720 
730 
740 
750 
760 
770 
780 
790 
800 
810 
820 
830 
840 
850 
860 
870 
880 
890 
900 
910 
920 
930 
940 
950 
960 
970 
980 
990 
1000 
1010 
1020 
1030 
1040 
1050 
1060 
1070 
1080 
1090 
1100 
1110 
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ELSE 

RKE = KE 
KEE = KE 

ENDIF 

C 

16 CA( NRP2+KEE*NR , I , K ) = 

1CA( NRP2+KEE*NR , I , K ) + CFF * BETCA * RKE * DFINTH ( 1+1 ) 

C 

17 CF ( I , I , K ) = CFF * DKC2 
C 

C DO I -FLUX TERMS BY LOOPING THROUGH INTERMEDIATE WHOLE POINTS, 

C INCREMENTING 6 TERMS EACH, FOR APPLICATION POINTS TO LEFT AND RIGHT. 
C THERE ARE NO FLUXES ON THE SIDES 
C 

DO 25 K = 1, NZ 
DO 25 I = 2, NR 
C 

C LEFT AND RIGHT FROM W TO APPLY FLUX 
C 

DO 25 ID = 1, 0, -1 

IDM = ID + ID -1 


C 

C LEFT AND RIGHT FROM W TO GET FLUX 
C 

DO 25 IE = -1, 0 
I EM = IE+IE+1 
C 

CA ( NRP 2 + 1 E+ 1 D , I - 1 D , K ) = 

1CA( NRP2 + IE+ID , I - ID , K ) - CRD ( I , K+l ) * IDM* I EM + CRG ( I , K + l ) * IDM 

C 

C UP AND DOWN FOR SLOPING MESH DIFFUSION TERM 
C 

DO 20 KE = -1, 1, 2 


C 

C SPECIAL TREATMENT FOR SLOPING -MESH TERMS AT TOP AND BOTTOM 
C INTERFACE TREATMENT IS COMPLETED BELOW 
C 

IF (K .EQ. 1 .AND. KE . EQ . -1) THEN 

RKE = - CTMULT( I+l+IE) 

KEE = 0 

ELSE IF (K .EQ. NZ .AND. KE .EQ. 1) THEN 
RKE = -1 
KEE = 0 

ELSE 

RKE = KE 
KEE = KE 

ENDIF 

20 CA( NRP2+IE+ID+KEE*NR, I - ID, K) = 

1CA( NRP2 + IE+ID+KEE*NR , I - ID , K ) + CRE( I , K+l ) * I DM* RKE 


C 

C DO THE INTERFACE CHANGE TERMS IN THE SAME I, K, ID, AND IE LOOPS 
C NOW GO LEFT AND RIGHT TO H NEIGHBORS 
C 

25 CF ( I + IE , I - ID , K ) = 

1CF( I + IE, I - ID , K ) + CRF ( I , K+l ) * IDM * I EM * DIDRW(I) 


C 

C DO K-FLUX TERMS BY LOOPING. THROUGH INTERMEDIATE WHOLE POINTS, 
C INCREMENTING 6 TERMS EACH, FOR POINTS TO DOWN AND UP. 
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1170 

1180 

1190 

1200 

1210 

1220 

1230 

1240 

1250 

1260 

1270 

1280 

1290 

1300 

1310 

1320 

1330 

1340 

1350 

1360 

1370 

1380 

1390 

1400 

1410 

1420 

1430 

1440 

1450 

1460 

1470 

1480 

1490 

1500 

1510 

1520 

1530 

1540 

1550 

1560 

1570 

1580 

1590 

1600 

1610 

1620 

1630 

1640 

1650 

1660 

1670 

1680 

1690 

1700 

1710 

1720 

1730 

17d(l 


c 

DO 35 K = 2, NZ 
DO 35 I = 1, NR 
C 

C DOWN AND UP FROM W TO APPLY FLUX 
C 

DO 35 KD = 1, 0, -1 

KDM = KD + KD -1 
C 

C DOWN AND UP FROM W TO GET FLUX 
C 

DO 30 KE = -1, 0 
KEM = KE+KE+1 
C 

CA (NRP2+(KE+KD) *NR , I , K - KD ) = 

1CA ( NRP2 + ( KE+KD ) *NR , I , K - KD ) - CZD ( 1+1 , K ) *KDM*KEM+CZG( 1+1 , K ) *KDM 

C 

C LEFT AND RIGHT FOR SLOPING MESH DIFFUSION TERM 
C 

DO 30 IE = -1, 1, 2 


C 

C AXIS SYMMETRY AND ONE-SIDED DIFFERENCE AT RIGHT EDGE USED IN GETTING C 
C 

IF (I .EQ. NR) THEN 

I EE = MIN ( 0 , IE ) 

RIE = 2 * I E 

ELSE IF (I .EQ. 1) THEN 
IEE = MAX ( 0 , I E ) 

RIE = IE 

ELSE 

IEE = IE 
RIE = IE 

END IF 


C 

30 CA(NRP2+ ( KE+KD ) *NR+IEE , I , K-KD) = 

1CA( NRP2+ (KE+KD ) +NR+IEE , I , K - KD ) + CZE ( 1+1 , K ) * KDM* RIE 
C 

C DO THE INTERFACE CHANGE TERMS IN THE SAME I, K, AND KD LOOPS 
C 

IF (I .EQ. NR) THEN 
IWS = 1 

ELSE 


IWS = 0 


END IF 


C 

C LOOP 
C ONLY 
C 

C 


OVER TWO W POINTS (NORMALLY JUST THE NEIGHBORS) 
DO IW = 0 NEAR AXIS, SINCE F IS SYMMETRIC. 

DO 35 IW = IWS, MIN ( IWS + 1 , I - 1 ) 

WM = 0.5 + IWS - 2* (IW- IWS)* IWS 


c 

c 

c 

c 

c 

c 


IWS 

IWS 


= 0 
= 1 


GIVES 

GIVES 


( IW,WM) 
( IW , WM ) 


= (0,0.5) 
= (1,1-5) 


AND 

AND 


(1,0.5) 
(2, -0.5) 


NOW GO LEFT AND RIGHT TO H NEIGHBORS 


DO 35 IE 


-1 . 0 
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1750 

1760 

1770 

1780 

1790 

1800 

1810 

1820 

1830 

1840 

1850 

1860 

1870 

1880 

1890 

1900 

1910 

1920 

1930 

1940 

1950 

1960 

1970 

1980 

1990 

2000 

2010 

2020 

2030 

2040 

2050 

2060 

2070 

2080 

2090 

2100 

2110 

2120 

2130 

2140 

2150 

2160 

2170 

2180 

2190 

2200 

2210 

2220 

2230 

2240 

2250 

2260 

2270 

2280 

2290 

2300 

2310 

2320 


C 

35 


IEM = IE+IE+1 
CF ( 1 + 1 - IW+IE , I , K - KD ) = 

1CF( I+1-IW+IE,I,K-KD) + CZF ( 1+1 , K ) * KDM * IEM 
1 * WM * DIDRW ( 1 + 1 - IW ) 


C 

C 

C DO DOMAIN TOP K FLUX. NO SLOPING-MESH TERM. 

C 

DO 40 I = 1, NR 
40 CA ( NRP2 ,1,1) = 

1CA ( NRP2 ,1,1) 

1 + CZD(I + 1, !)*(!•■ CTMULT ( 1 + 1 ) ) 

1 - CZG(I+1,1)*(1. + CTMULT ( 1+1 ) ) 

C 

C DO INTERFACE 

C PUT dT COEFFICIENTS IN THE UNUSED RIGHT OF THE DIAGONAL 
C 

C EXTRA Ci TERM 
C 

DO 50 I = 2, NR 
DO 50 ID - 1, 0, -1 

RID = ( ID + ID - 1 ) * 2 . 

DO 50 IE = -1, 0 

50 CA ( NRP2+IE+ID+NR , I - ID , NZ ) = 

1CA(NRP2+IE+ID+NR,I-ID,NZ) + CRE ( I , NZPl ) * RID 
C 

C DO Ck TERMS 
C 

DO 70 I = 1, NR 
C 

CA ( NRP2 , I , NZ ) = 

1CA ( NRP2 , I , NZ ) + 2 . *CZD( 1+1 ,NZPl ) 

CA ( NRP2+NR , I , NZ ) = 

1CA ( NRP2 + NR , I , NZ ) + ( CZG ( 1 + 1 , NZPl )- CZD( 1 + 1 , NZPl ) ) * 2 
C 

C LEFT AND RIGHT FOR SLOPING MESH DIFFUSION TERM 
C 

DO 60 IE = -1, 1, 2 
C 

C AXIS SYMMETRY AND ONE-SIDED "DIFFERENCE AT RIGHT EDGE USED IN GETTING D 
C 

IF (I .EQ. NR) THEN 

IEE = MIN( IE, 0 y 
RIE = 2* IE 

ELSE IF (I .EQ. 1) THEN 
IEE = MAX ( IE, 0 ) 

RIE = IE 

ELSE 

IEE = IE 
RIE = IE 

ENDIF 

60 CA( NRP2+NR+IEE , I , NZ ) = 

1CA ( NRP2+NR+IEE , I , NZ ) + CZE ( 1+1 ,NZPl ) *2 . *RIE 
C 

C DO THE INTERFACE DF TERMS IN THE SAME I LOOP 
C 

IF (I .EO. NR) THEN 


N) to hJ N) M K) w 


MI PS4$DRA3 : [ ROBERTS . BS ] PT2 . ;1 


18 - SEP - 1986 19:45 


Page 6 


2330 
340 
350 
360 
370 
380 
390 
400 
2410 
2420 
2430 
2440 
2450 
2460 
2470 
2480 
2490 
2500 
2510 
2520 
2530 
2540 
2550 
2560 
2570 
2580 
2590 


ELSE 

ENDIF 


IWS = 1 
IWS = 0 


C LOOP OVER TWO W POINTS (NORMALLY JUST THE NEIGHBORS) 
C 

DO 70 IW = IWS, MIN ( IWS + 1 , 1 - 1 ) 

C 

WM = 0.5 + IWS - 2 * ( IW - IWS ) * IWS 

c 

C IWS = 0 GIVES ( IW , WM ) - (0,0.5) AND (1,0.5) 

C IWS = 1 GIVES ( IW , WM ) = (1,1.5) AND (2, -0.5) 

e 

C NOW GO LEFT AND RIGHT TO H NEIGHBORS 
C 

DO 70 IE = -1, 0 
I EM = IE+IE+1 


C 

70 


CF(I+1-IW+IE,I,NZ) = 

1CF( I + l-IW+IE,! ,NZ ) + CZF ( 1 + 1 ,NZPl ) * I EM * WM * DIDRW( 1 + 1 - IW) 


C WRITE ARRAY DIAGNOSTIC 
C 

IF (ISTEP .LE. 1 
C 
C 


.AND. NCB .LE. 67) THEN 
CALL WAC ( CA, NCB , NR*NZ , 2 , ' CA BEFORE% ' ) 
CALL WAC ( CF , NR , NR*NZ , 2 , ' CF BEFORE% ' ) 


2600 


ENDIF 

2610 

C 


2620 

C DOWNWARD L-U SWEEP (DECOMPOSITION) 

2630 

C 


2640 


DO 80 I = 1, NR* ( NZ - 1 ) 

2650 


DO 80 J = I + 1 , MI N ( NR*NZ , NRP 1+ I ) 

2660 


L = NRP2 - J + I 

2670 


AP = CA ( L , J , 1 ) /CA ( NRP 2,1,1) 

2680 


CA( L , J , 1 ) = AP 

2690 


IF (AP .EQ. 0 . ) GO TO 80 

2700 


DO 75 K = 1, NR 

2710 

75 

CF ( K , J , 1 ) = CF ( K , J , 1 ) - AP * CFi 

2720 


DO 79 K - 1, NRPl 

2730 


CA( L + K , J , 1 ) = CA(L + K,J-,1) - AP ' 

2740 

79 

CONTINUE 

2750 

80 

CONTINUE 

2760 

C 


2770 

C WRITE 

ARRAY DIAGNOSTIC 

2780 

C 


2790 


IF (ISTEP .LE. 1 .AND. NCB 

2800 

c 

CALL WAC ( CA, NCB , NR*NZ , 2 

2810 

c 

CALL WAC ( CF , NR , NR*NZ , 2 , 

2820 


ENDIF 

2830 

c 


2840 


RETURN 

62896 


END 


i 
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C ELIMINATE DC EXCEPT ADJACENT TO INTERFACE 
C SET RIGHT HAND SIDE TERMS FOR INTERFACE MATRIX 
C 

INCLUDE 'COM. /NOLIST' 

C 

C COPY DC INTO DCNG (NO GAPS) 

C 

DO 110 K = 1, NZ 
DO 110 I = 1, NR 
110 DCNG ( I , K ) = DC ( 1+1 , K+l ) 

C 

C ELIMINATE DC FROM THE TOP DOWN TO THE INTERFACE 
C 

DO 120 1=1, NR* ( NZ - 1 ) 

DO 120 J = 1+1 , MIN( NR*NZ , NRPl+I ) 

L = NRP2 - J + I 

DCNG ( J , 1 ) = DCNG ( J , 1 ) - CA(L,J,1) * DCNG (1,1) 
120 CONTINUE 

C 

C SET DCU ROWS OF INTERFACE MATRIX 
C 

IF ( LLF ) THEN 


(_ KATKiA ukulr: 

C BASE ( xNR , xNRA ) : 
C BASE ( xNR , xNRC ) : 


f"\ m T T c 

U LUO 

r\ rpTT A 
is ± un 

r\n nr c 

JU/ i. uu 

DTLA 

DF 

DT 

0,0 

1,0 

1,1 

2,1 

2,2 

3,2 

0,0 

1,0 

0,1 

1,1 

0,2 

1,2 


130 AI ( J , K 

C 

C SET DCU AND DF TERMS 
C 


DO 150 I = 1, NR 
J = I+NR*4+NRA*2 

DO 130 K = 1, NAI 
AI ( J , K) = 0 . 


DO 140 K = 1, NR 

AI ( J , NR* 4+NRA* 2 + K ) = CA( NRP2 + K - 1 , 1 , NZ ) 
AI ( J , NRC*2+K ) = CF ( K , I , NZ ) 


C SET DT TERMS (TRIDIAGONAL) 
C 


DO 150 K = MAX (1-1,1), MIN ( 1+1 , NR ) , 1 

AI ( J , NR* 3+NRA* 2 + K ) = CA( NRP2+NR+K - 1 , 1 , NZ ) * DCMDT ( K+l ) 


ENDIF 


C SET RIGHT HAND SIDES FOR INTERFACE MATRIX 
C 

DO 160 I = 1, NR 

160 BI ( NR* 4+NRA* 2 + 1 ) = DCNG(I,NZ) 

C 

RETURN 

END 


i 
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10 


SUBROUTINE 

CNC3 

20 

C 



30 

C BAND 

BACK SUBSTITUTION 

40 

C 



50 


INCLUDE ' COM./NO list ' 

60 

C 



70 

C DC IS 

ALREADY CORRECT ON THE BOTTOM ROW ( NZ ) 

80 

C 



90 


DO 20 I = 

NR* ( NZ - 1 ) , 1 , - 1 

100 


DO 10 J = 

1, MIN ( NRPl , NR*NZ - 1 ) 

110 

10 

DCNG ( 1,1) 

= DCNG (1,1) - CA ( NRP2+ J ,1,1) * DCNG(I+J,1) 

120 


DO 15 J = 

1, NR 

130 

15 

DCNG ( 1,1) 

= DCNG (1,1) - CF ( J , I , 1 ) * DFINTH ( J+l ) 

140 

20 

DCNG ( I , 1 ) 

= DCNG (1,1) / CA ( NRP2 ,1,1) 

150 

C 



160 

C RESTORE DCNG TO 

DC 

170 

C 



180 


DO 30 K = 

2, NZP1 

190 


DO 30 I = 

2, NRPl 

200 

30 

DC ( I , K ) = 

DCNG ( I - 1 , K - 1 ) 

210 

C 



220 


RETURN 


230 


END 




JL 
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10 

20 

30 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 

210 

n n n 
z, z, u 

230 

240 

250 

260 

270 

280 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


SUBROUTINE CNTl 
C 

C SET UP AND L-U DECOMPOSE THE BANDED MATRIX TA 

C SET UP INTERFACE MATRIX TF AND INCLUDE IN THE DECOMPOSITION 
C 

INCLUDE ' COM. /NOLIST' 


C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


WRITE ARRAY CHARACTER DIAGNOSTICS 

IF (ISTEP .EQ. 1) THEN 

CALL WAC( TRD,NRCP2 ,NZCPl,2, ' TRD% ' ) 
CALL WAC ( TRE , NRP2 , NZCPl , 2 ,’ TRE% ' ) 
CALL WAC ( TRF , NRP2 , NZCPl , 2 , ' TRF% ' ) 
CALL WAC ( TRG , NRP2 , NZPl , 2 TRG% ' ) 
CALL WAC ( TZD , NRCP2 , NZCPl , 2 , ' TZD% ' ) 
CALL WAC ( TZE , NRP2 , NZCPl , 2 , ' TZE% ' ) 
CALL WAC(TZF,NRP2,NZCPl,2, 'TZF%' ) 
CALL WAC(TZG,NRCP2,NZCPl,2, 'TZG%' ) 

ENDIF 


C 

C 

c 

c 

c 


SET TA ( J , I , K ) AND TF(J,I,K) FOR HH POINTS 


CLEAR TF AND TA 


( 1 + 1 ,K+1 ) 


C DO MOVING -MESH TERMS, BOTH TA AND TF 
C SET TA- DIAGONAL TO TVBT 
C 



DO 90 K = 

1, NZC 


DO 90 I = 

1, NRC 

c 

DO 50 J = 

1 , NR 

50 

TF ( J , I , K ) 

= 0 

C 

DO 60 J = 

1 , NTB 

60 

TA ( J , I , K ) 

= 0 . 


C 

C 

C SPECIAL REPRESENTATIONS FOR DKT2 AND ITS CHANGE 

C THE REPRESENTATION NEXT TO THE INTERFACE INCLUDES TINTH 

C 

DKT2 = T ( 1+1 , K+2 ) - T( 1+1 , K ) 

TFF = - RDRB2H ( 1+1 ) * ETAH ( K+l ) * CP(I+1,K+1) 

IF (I .LE. NR) THEN 

TFF = TFF * BTF ( 1+1 ) 


ELSE 


TFF = TFF * BTF(NRPl) 


ENDIF 


C 

C 


DO 7 0 KE = - 1 , 1 , 2 

IF (K .EQ. 1) THEN 
RKE = 1 

KEE = MAX ( KE , 0 ) 
ELSE IF (K .EQ. NZC) THEN 
RKE = -1 
KEE = M I N ( K E , 0 ) 
ELSE IF (K .EQ. NZ ) THEN 
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590 



KEE = MIN ( KE , 0 ) 

600 



IF (I .GT. NR) THEN 

610 



DKT2 = ( T ( 1 + 1 , K+l ) - T( 1 + 1 , K ) ) *2 

620 



RKE = KE*2 

630 



ELSE 

640 



DKT2 = 2 *TINTH ( 1 + 1 ) - (T(I + 1,K+1) + T(I + 1,K)) 

650 



TA( NRCP2+NRC, I ,K) = 

660 


1 

TA( NRCP2+NRC, I ,K) + TFF * BETTA * DFINTH(I+1) 

670 

C 


- 

680 

C TA IS INCREMENTED TWICE, BOTH HERE AND BELOW, SO A FACTOR 2 IS OMITTED 

690 

C 



700 



RKE = -1 

710 



ENDIF 

720 


ELSE IF (K .EQ. NZPl ) THEN 

730 



KEE = MAX ( KE , 0 ) 

740 



IF (I .GT. NR) THEN 

750 



DKT2 = ( T ( I +1 , K+2 ) - T(I+1,K+1)) *2 

760 



RKE = KE*2 

770 



ELSE 

780 



DKT2 = ( T ( 1+1 , K+2 ) + T ( 1+1 , K+l ) ) - 2*TINTH(I+1) 

790 



TA( NRCP2 -NRC , I , K ) = 

800 


1 

TA ( NRCP2 - NRC , I , K ) - TFF * BETTA * DFINTH(I+1) 

810 



RKE = 1 

820 



ENDIF 

830 


ELSE 


840 



RKE = KE 

850 



KEE = KE 

860 


ENDIF 


870 

C 



880 

70 

TA( NRCP2+KEE*NRC , I , K ) = 

890 


1TA ( NRCP2 + KEE*NRC , I , K ) + TFF * BETTA * RKE * DFINTH(I + 1) 

900 

C 



910 


TFT = 

TFF * DKT2 

920 

C 



930 


IF (I 

.LE. NR) THEN 

940 



TF ( I , I , K ) = TFT 

950 


ELSE 


960 



DO 80 J = 1, 3 

970 

80 


TF ( NRPl - J , I , K ) = TFT * FABC(J) 

980 


ENDIF 


990 

C 



1000 

C 

VOLUME OVER 

TIME STEP ON. THE DIAGONAL 

:i 1010 

C 



1020 


VBT = 

TVBTRH ( 1+1 ) *TVBTZH{ K+l ) 

1030 


i 

* ( 1+RFINTH( 1+1 ) *DEDZTH( K+l ) ) * CP(I+1,K+1) 

1040 

C 



1050 

C 

CORRECT VBT 

IN CRYSTAL 

1060 

c 



1070 


IF ( K 

.GE. NZPl .AND. I .LE. NR) VBT = VBT * TAUT / TAUS 

1080 

c 



1090 

90 

TA( NRCP2 , I , K ) = 

1100 


1TA ( NRCP2 , I , K ) + VBT 

1110 

c 



1120 

c 

TF WRONG? 


1130 

c 



1140 


IF (ISTEP .EQ. 1) THEN 

1150 

c 


CALL WAC ( TF , NR , NRC*NZC , 2 , ' TF BEFORE SLOPE TERMS % ' ) 

1160 


ENDIF 
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1170 

1180 

1190 

1200 

1210 

1220 

1230 

1240 

1250 

1260 

1270 

1280 

1290 

1300 

1310 

1320 

1330 

1340 

1350 

1360 

1370 

1380 

1390 

1400 

1410 

1420 

1430 

1440 

1450 

1460 

1470 

1480 

1490 

1500 

1510 

1520 

1530 

1540 

1550 

1560 

1570 

1580 

1590 

1600 

1610 

1620 

1630 

1640 

1650 

1660 

1670 

1680 

1690 

1700 

1710 

1720 

1730 

17/in 


C 

c 

c 

c DO I -FLUX TERMS 

C 

c 

C LOOP THROUGH INTERMEDIATE WHOLE POINTS, 

C INCREMENTING 6 TERMS EACH, FOR POINTS TO LEFT AND RIGHT. 
C THERE IS NO FLUX ON THE LEFT 
C 

DO 130 K = 1, NZC 
DO 130 I = 2, NRC 
C 

C LEFT AND RIGHT FROM W TO APPLY FLUX 
C 

DO 130 ID = 1, 0, -1 
IDM = ID + ID -1 


C 

C DO THE TEMPERATURE CHANGE TERMS 

C 

C 

C LEFT AND RIGHT FROM W TO GET FLUX 
C 

DO 110 IE = -1, 0 
I EM = IE+IE+1 
C 

TA(NRCP2+IE+ID,I-ID,K) = 

1TA( NRCP2 + IE+ID , I - ID,K) 

1 - TRD( I , K+l ) * I DM* I EM 

IF ( LU .AND. K .LE. NZ .AND. I .LE. NR) 
1 TA (NRCP2 + IE+ID, I - ID, K) = 

1 TA ( NRCP2 + I E + ID , I - ID , K ) 

1 + TRG( I , K+l ) *IDM 


C 

C NO SLOPING-MESH DIFFUSION TERMS WITHIN THE AMPOULE 
C 

IF (I .GT. NRPl ) GO TO 110 
C 

C UP AND DOWN FOR SLOPING MESH DIFFUSION TERM 
C 

DO 100 KE = -1, 1, 2 ' 

C 

C SPECIAL TREATMENT FOR SLOPING -MESH TERMS AT TOP AND 
C SPECIAL INTERFACE TREATMENT IS COMPLETED BELOW 
C 

IF (K .EQ. 1) THEN 
RKE = 1 

KEE = MAX ( KE , 0 ) 

ELSE IF (K .EQ. NZC) THEN 
RKE = -1 
KEE = MIN ( KE , 0 ) 

ELSE IF (K .EQ. NZ ) THEN 

IF (I .EQ. NRPl) THEN 
RKE = KE* 2 
KEE = MIN ( KE , 0 ) 


BOTTOM (T IMPOSED) 


RKE = -1 

KEE = MIN ( KE , 


0 ) 


ELSE 
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1750 


ENDIF 


1760 


ELSE IF (K .EQ. NZPl ) THEN 


1770 


IF (I .EQ. NRPl ) THEN 


1780 


RKE = KE * 2 


1790 


KEE = MAX ( KE , 0 ) 


1800 


ELSE 


1810 


RKE = 1 


1820 


KEE = MAX ( KE , 0 ) 


1830 


ENDIF 


1840 


ELSE 


1850 


RKE = KE 


1860 


KEE = KE 


1870 


ENDIF 


1880 

C 



1890 


TA(NRCP2+IE+ID+KEE*NRC, I-ID,K) = 


1900 


1TA(NRCP2+IE+ID+KEE*NRC, I-ID,K) + TRE( I , K+l ) * I DM* RKE 


1910 

100 

CONTINUE 


1920 

110 

CONTINUE 


1930 

C 



1940 

C DO THE INTERFACE CHANGE TERMS IN THE SAME I, K, AND ID LOOPS 

1950 

c 



I96 0 


IF (I .GT. NRPl) THEN 


1970 


GO TO 130 


1980 


ELSE IF (I .EQ. NRPl) THEN 


1990 


NW = 1 


2000 


ELSE 


2010 


NW = 0 


2020 


ENDIF 


2030 

c 



2040 

C LOOP 

OVER W POINTS ( NORMALLY JUST THE SAME POINT) 


2050 

c 



2060 


DO 120 JW = 0 , NW 


2070 

c 



2080 


IW = JW + NW 


2090 


WM = NW + 1 - 3 * JW 


2100 

c 



2110 

C NW = 

0 GIVES ( JW , IW , WM ) = (0,0,1) 


2120 

C NW = 

1 GIVES ( JW , IW , WM ) = (0,1,2) AND (1,2, -1) 


2130 

c 



2140 

C NOW 

GO LEFT AND RIGHT TO H NEIGHBORS 


2150 

C 

~ 


2160 


DO 120 IE =-1,0 . 


A 2170 


I EM = IE+IE+1 


2180 

c 



2190 

120 

TF ( I - IW+IE , I - ID , K ) = 


2200 


1TF ( I - IW+IE , I - ID , K ) + TRF ( I , K+l ) * IDM * I EM * WM * 

DIDRW ( I - IW) 

2210 

130 

CONTINUE 


2220 

C 



2230 

C 



2240 

C 

DIFFUSION AT AMPOULE BOUNDARY 


2250 

C 



2260 


DO 140 K = 1, NZC 


2270 

140 

TA(NRCP2,NRC,K) = TA(NRCP2 ,NRC,K) 


2280 


1 + TRD ( NRCPl , K+l ) * (1. - TRBM ( K+l ) ) 


2290 

C 



2300 

C 



2310 

C 

DO K-FLUX TERMS 


2320 

C 
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2350 

C 

INTERFACE IS DONE SEPARATELY 

2360 

C 



2370 



DO 180 K = 2, NZC 

2380 



IF (K .EQ. NZP1) THEN 

2390 



IB = NRP1 

2400 



ELSE 

2410 



IB = 1 

2420 



ENDIF 

2430 



DO 180 I = IB, NRC 

2440 

C 



2450 

C 

DOWN 

AND UP FROM W TO APPLY FLUX 

2460 

C 



2470 



DO 180 KD = 1, 0, -1 

2480 



RDM = KD + KD -1 

2490 

c 



2500 

c 

DOWN 

AND UP FROM W TO GET FLUX 

2510 

c 



2520 



DO 160 KE = -1, 0 

2530 



KEM = KE+KE+1 

2540 

c 



2550 



TA ( NRCP2+ ( KE+KD ) *NRC , I , K - KD ) = 

2560 



1TA ( NRCP2+ ( KE+KD ) *NRC , I , K - KD ) - TZD(I+1,K 

2570 



1 + TZG( 1+1 

2580 

c 



2590 

c 

NO SLOPING-MESH DIFFUSION TERMS IN THE AMPOULE 

2600 

c 



2610 



IF (I .GT. NR) GO TO 160 

2620 

c 



2630 

c 

LEFT 

AND RIGHT FOR SLOPING MESH DIFFUSION TERM 

2640 

c 



2650 



DO 150 IE = -1, 1, 2 

2660 

c 



2670 

c 

AXIS 

SYMMETRY USED IN GETTING Ck 

2680 

c 

ONE- 

SIDED DIFFERENCE NEXT TO THE AMPOULE 

2690 

c 



2700 



IF (I .EQ. 1 .AND. IE .EQ. -1) THEN 

2710 



IEE = 0 

2720 



RIE = IE 

2730 



ELSE IF (I .EQ. NR) THEN 

2740 



IEE = MIN ( 0 , IE) 

2750 



RIE = 2* IE 

2760 



ELSE 

2770 



IEE = IE 

2780 



RIE = IE 

2790 



ENDIF 

2800 

150 

TA( NRCP2+ ( KE+KD ) *NRC+ I EE , I , K - KD ) = 

2810 



1TA (NRCP2+(KE+KD) *NRC+ I EE , I , K - KD ) + TZE(] 

2820 

160 

CONTINUE 

2830 

C 



2840 

C 

DO THE INTERFACE CHANGE TERMS IN THE SAME I, K, 

2850 

c 



2860 



IF (I .GT. NR) THEN 

2870 



GO TO 180 

2880 



ELSE IF (I .EQ. NR) THEN 

2890 



IWS = 1 

2900 



ELSE 
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2910 


IWS = 0 


2920 


ENDIF 


2930 

C 



2940 

C LOOP 

OVER TWO W POINTS (NORMALLY JUST THE NEIGHBORS) 


2950 

C 



2960 


DO 170 IW = IWS, MIN ( IWS + 1 , I - 1 ) 


2970 

C 



2980 


WM = 0.5 + IWS - 2* ( IW- IWS ) * IWS 


2990 

C 

' 


3000 

C IWS 

= 0 GIVES ( IW , WM ) = (0,0.5) AND (1,0.5) 


3010 

C IWS 

= 1 GIVES ( IW,WM ) = (1,1.5) AND (2, -0.5) 


3020 

c 



3030 

C NOW 

GO LEFT AND RIGHT TO H NEIGHBORS 


3040 

C 



3050 


DO 170 IE - -1, 0 


3060 


I EM = IE+IE+1 


3070 

c 



3080 

170 

TF( I+l-IW+IE, I ,K-KD) = 


3090 


1TF( 1 + 1 - IW+IE , I , K-KD) + TZF ( 1 + 1 , K ) * RDM * IEM * 


3100 


1 WM * DIDRW( 1 + 1 - IW) 


3110 

180 

CONTINUE 


jiZU 

r> 

U 



3130 

c 



3140 

c 

DO DOMAIN TOP AND BOTTOM 


3150 

c 



^ r A 

^ _L O U 


DO 190 1=1, NRC 


3170 


TA( NRCP2 , I , NZC ) = TA ( NRCP2 , I , NZC ) + 2 *TZD ( 1+1 , NZCPl ) 


3180 

190 

TA(NRCP2,I, 1) = TA(NRCP2 , I , 1) + 2*TZD( 1+1 , 1 ) 


3190 

C 



3200 

C 



3210 

C 

DO INTERFACE 


3220 

C 



3230 

C PUT 

dTINT COEFFICIENTS TO THE RIGHT OF THE DIAGONAL FOR DTSU EQUATIONS 


3240 

C PUT 

dTINT COEFFICIENTS TO THE LEFT OF THE DIAGONAL FOR DTSL EQUATIONS 


3250 

C 



3260 

C EXTRA Ci TERM 


3270 

C 



3280 


DO 200 I = 2, NR 


3290 


DO 200 ID = 1, 0, -1 


3300 


RID = ( ID + ID - 1 ) * 2 . 

i 

3310 


DO 200 IE = -1, 0 


3320 


TA(NRCP2+IE+ID+NRC,I-ID,NZ ) = 

d 

3330 


1TA( NRCP2 + IE+ID+NRC , I - ID , NZ ) + TRE(I,NZPl) * RID 


3340 

200 

TA ( NRCP2 + IE+ID - NRC , I - ID , NZPl ) = 


3350 


1TA(NRCP2+IE+ID-NRC,I - ID,NZP1 ) - TRE(I,NZP2) * RID 


3360 

c 



3370 

C DO 

Ck TERMS 


3380 

C TZ % 

( I , NZPl ) REFERS TO THE MELT. THE CRYSTAL TERMS ARE IN TZIC%(I). 


3390 

c 



3400 


DO 218 I = 1, NR 


3410 

c 



3420 


TA(NRCP2 , I ,NZ ) = 


3430 


1TA(NRCP2 , I ,NZ ) + TZD( 1+1 ,NZPl ) *2 . 


3440 

c 



3450 


TA( NRCP2+NRC , I , NZ ) = 


3460 


1TA( NRCP2+NRC , I , NZ ) + ( TZG ( I +1 , NZPl ) - TZD( 1+1 ,NZPl ) ) *2 . 


3470 

c 



3480 


TA( NRCP2 , I ,NZPl ) = 
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3490 


1TA(NRCP2,I,NZP1) + TZICD(I+1)*2. 

■ 

3500 

C 



3510 


TA( NRCP2 -NRC , I ,NZPl ) = 


3520 


1TA(NRCP2-NRC,I,NZP1) - ( TZ I CG ( 1+1 ) + TZICD(I+1) 

) * 2 . 

3530 

C 



3540 

C LEFT 

AND RIGHT FOR SLOPING MESH DIFFUSION TERM 


3550 

c 



3560 


DO 210 IE = -1, 1, 2 


3570 

C 

- 


3580 

C AXIS 

SYMMETRY AND ONE-SIDED DIFFERENCE AT RIGHT EDGE USED IN GETTING D 

3590 

c 



3600 


IF (I .EQ. NR) THEN 


3610 


RIE = 2*IE 


3620 


IEE = MIN ( 0 , IE ) 


3630 


ELSE IF (I .EQ. 1 .AND. IE .EQ. -1) THEN 


3640 


IEE = 0 


3650 


RIE = IE 


3660 


ELSE 


3670 


IEE = IE 


3680 


RIE = IE 


3690 


ENDIF 


3700 

c 



3710 


TA( NRCP2+NRC+IEE , I , NZ ) = 


3720 


1TA ( NRCP2+NRC+I EE , I , NZ ) + TZE( 1+1 ,NZPl ) *2 . *RIE 


3730 

210 

TA ( NRCP2 - NRC+I EE , I , NZPl ) = 


J < *s w 


- 1TA( NRCP2 -NRC+I EE , I , NZPl ) + TZICE( 1+1 ) *2 . *RIE 


3750 

C 



3760 

C DO THE INTERFACE DF TERMS IN THE SAME I LOOP 


3770 

C 



3780 


IF (I .EQ. NR) THEN 


3790 


IWS = 1 


3800 


ELSE 


3810 


IWS = 0 


3820 


ENDIF 


3830 

c 



3840 

C LOOP 

OVER TWO W POINTS (NORMALLY JUST THE NEIGHBORS) 


i 3850 

C 



3860 


DO 218 IW = IWS, MIN ( IWS + 1 , 1 - 1 ) 


3870 

C 



5 3880 


WM = 0.5 + IWS - 2* ( IW- IWS ) *IWS 


1 3890 

C 

- 


| 3900 

C IWS 

= 0 GIVES ( IW , WM ) = (0,0.5) AND (1,0.5) 


\ 3910 

C IWS 

= 1 GIVES ( IW , WM ) = (1,1.5) AND (2, -0.5) 


* 3920 

c 



3930 

C NOW 

GO LEFT AND RIGHT TO H NEIGHBORS 


3940 

c 



3950 


DO 218 IE = -1, 0 


3960 


I EM = IE+IE+i 


3970 

c 



3980 


TF(I+1-IW+IE,I,NZ) = 


3990 


1TF( I+l-IW+IE, I ,NZ ) + TZF ( 1+1 ,NZPl ) * I EM * WM 

* DIDRW ( 1 + 1 - IW) 

4000 

218 

TF ( 1 + 1 - IW+IE , I , NZPl ) = 


4010 


1TF ( 1 + 1 - IW+IE , I , NZPl ) - TZ I CF ( 1 + 1 ) * IEM * WM * 

DIDRW ( 1+1 -IW) 

4020 

C WRITE ARRAY DIAGNOSTIC 


4030 

C 



4040 


IF (ISTEP .LE. 1 .AND. NTB .LE. 67) THEN 


4050 

C 

CALL WAC ( TA , NTB , NRC*NZC , 2 , ' TA BEFORE% ' ) 


4060 

c 

CALL WAC ( TF ,^R , NRC*NZC , 2 , ' TF BEFORE% ' ) 
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4070 


ENDIF 

4080 

C 


4090 

C DOWNWARD L-U SWEEP (DECOMPOSITION) 

4100 

C 


4110 


DO 240 1=1, NRC* ( NZ - 1 ) 

4120 


DO 240 J = 1+1, MIN ( NRC* NS , NRC Pi + I ) 

4130 


L = NRCP2 - J + I 

4140 


AP = TA ( L , J , 1 ) /TA ( NRCP2 ,1,1) 

4150 


TA( L, J , 1 ) = AP 

4160 


IF (AP .EQ. 0. ) GO TO 240 

4170 


DO 220 K = 1, NR 

4180 

220 

TF ( K , J , 1 ) = TF ( K , J , 1 ) - AP * TF(K,I,1) 

4190 


DO 230 K = 1, NRCPl 

4200 


TA ( L+K , J , 1 ) = TA ( L+ K , J , 1 ) - AP * TA(NRCP2 + K,I 

4210 

230 

CONTINUE 

4220 

240 

CONTINUE 

4230 

C 


4240 

C UPWARD L-U SWEEP ( DECOMPOSITION ) 

4250 

C 


4260 


DO 270 I = NRC*NZC , NRC*NZP1+1, -1 

4270 


DO 270 J = 1-1, MAX( NRC*NZ+1 , I -NRCPl ) , -1 

a -> q n 

-1 X- W 


L - NRCP2 + I - J 

4290 


AP = TA(L,J,1)/TA(NRCP2,I,1) 

4300 


TA ( L , J , 1 ) = AP 

4310 


IF (AP .EQ. 0 . ) GO TO 270 

4320 


DO 250 K = 1, NR 

4330 

250 

TF ( K , J , 1 ) = TF ( K , J , 1 ) - AP * TF(K,I,1) 

4340 


DO 260 K = 1, NRCPl 

4350 


TA ( L - K , J , 1 ) = TA ( L - K , J , 1 ) - AP * TA(NRCP2-K,I 

4360 

260 

CONTINUE 

4370 

270 

CONTINUE 

4380 

C 


4390 

C WRITE 

ARRAY DIAGNOSTIC 

4400 

C 


4410 


IF (ISTEP .LE. 1 .AND. NTB . LE . 67) THEN 

4420 

C 

CALL WAC ( TA , NTB , NRC*NZC , 2 , ' TA AFTER% ' 

4430 

C 

CALL WAC ( TF , NR , NRC*NZC , 2 , ' TF AFTER% ' ) 

4440 


ENDIF 

4450 

C 


4460 


RETURN 

63136 


END 
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10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 

450 C 

460 C MATRIX ORDER: 

470 C BASE ( xNR , xNRA ) : 

480 C BASE ( xNR , xNRC ) : 

490 C 

500 DO 310 I = 

510 DO 310 K = 

520 310 AI ( I , K ) = 

530 C 

540 C SET DTU AND DF TERMS 
550 C 

560 DO 330 I = 

57 0 DO 3 20 K = lj 

580 320 AI ( I ,NRC*2+K) 


DTUA 

DTLS 

DTLA 

DF 

DT 

1,0 

1,1 

2,1 

2,2 

3,2 

1 , 0 

0,1 

1,1 

0,2 

1,2 


NRC* 2 
NAI 


NRC 

NR 

= TF ( K, I ,NZ ) 


SUBROUTINE CNT2 
C 

C ELIMINATE DT EXCEPT ADJACENT TO INTERFACE 
C SET RIGHT HAND SIDE TERMS FOR INTERFACE MATRIX 
C 

INCLUDE ' COM. /NOLIST' 

C 

C COPY DT INTO DTNG (NO GAPS) 

C 

DO 280 K = 1, NZC 
DO 280 I = 1, NRC 
280 DTNG ( I , K ) = DT(I+1,K+1) 

C 

C WRITE DT ARRAY DIAGNOSTIC 
C 

IF (ISTEP .LE. 1 .AND. NRC .LE. 67) THEN 
C CALL WAC ( DTNG , NRC , NZC , 2 , ' DT BEFORE% ' ) 

END IF 
C 

C ELIMINATE DT FROM THE TOP DOWN TO THE INTERFACE 
C 

DO 290 1 = 1, NRC* ( NZ - 1 ) 

DO 290 J = 1+1, MIN ( NRC*NZ , NRCPl+I ) 

L = NRCP2 - J + I 

DTNG ( J , 1 ) = DTNG ( J , 1 ) - TA(L,J,1) * DTNG (1,1) 

290 CONTINUE 

C 

C ELIMINATE DT FROM THE BOTTOM UP TO THE INTERFACE 
C 

DO 300 I = NRC*NZC , NRC*NZP1+1, -1 
DO 300 J = 1-1, MAX ( NRC *NZ + 1 , 1 - NRC Pi ) , -1 

L = NRCP2 + I - J 

DTNG ( J , 1 ) = DTNG ( J , 1 ) - TA(L,J,1) * DTNG (1,1) 

300 CONTINUE 

C 

C WRITE DT ARRAY DIAGNOSTIC 
C 

IF (ISTEP .LE. 1 .AND. NRC .LE. 67) THEN 
C CALL WAC (DTNG, NRC, NZC, 2, 'DT AFTER ELIMINATION 5 ! ' ) 

END IF 
C 

C SET DTU ROWS OF INTERFACE MATRIX 
C 

IF ( LLF ) THEN 

DTUS 
0,0 
0,0 

1, 

1, 

0. 


1 , 
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590 


DO 330 K - 1, NRC 

600 

330 

AI ( I , K ) = TA( NRCP2+K - 1 , I , NZ ) 

610 

C 


620 

C SET 

DT TERMS (TRIDIAGONAL) FOR DTUS 

630 

C 


640 


DO 340 I = 1, NR 

650 


DO 340 K = MAX (1,1-1) , MIN(NR,I+1) 

660 

340 

AI ( I , NR+NRC * 2 + K ) = TA ( NRCP2 + NRC + K -1,1, NZ ) 

670 

C 

- 

680 

C SET 

DTLA TERMS (DIAGONAL) FOR DTUA 

690 

C 


700 


DO 350 I = NRPl , NRC 

710 

350 

AI ( I , NRC+ I ) = TA ( NRCP2+NRC , I , NZ ) 

720 

C 


730 

C SET 

DTL AND DF TERMS 

740 

C 


750 


DO 370 1=1, NRC 

760 


DO 360 K = 1, NR 

770 

360 

A I ( NRC+ I , NRC* 2+K ) = TF(K,I,NZPl) 

780 


DO 370 K = 1, NRC 

790 

370 

AI ( NRC+I , NRC + K ) = TA ( NRCP2 + K - 1 , 1 , NZP1 ) 

800 

C 


810 

C SET 

DT TERMS (TRIDIAGONAL) FOR DTAS 

820 

C 


830 


DO 380 I = 1, NR 

840 


DO 380 K = MAX (1,1-1) , MIN ( NR , 1+1 ) 

850 

380 

AI (NRC+I ,NR+NRC*2+K) = TA(NRCP2 -NRC+K- I , I ,NZPl ) 

860 

C 


870 

C SET 

DTUA TERMS (DIAGONAL) FOR DTLA 

880 

C 


890 


DO 390 I = NRPl, NRC 

900 

390 

AI (NRC+I, I) = TA ( NRCP2 - NRC , I , NZPl ) 

910 

C 


920 


END IF 

930 

C 


940 

C SET 

RIGHT HAND SIDES FOR INTERFACE MATRIX 

950 

C 


960 


DO 400 1 = 1 , NRC* 2 

970 

400 

BUI) = DTNG ( I , NZ ) 

980 

C 


990 


RETURN 

65B88 


END 
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10 


SUBROUTINE CNT3 



20 





30 

C 




40 

C BAND 

BACK SUBSTITUTION 



50 

C 




60 


INCLUDE 'COM. /NOLIST' 



70 

C 




80 

C DTNG 

IS ALREADY CORRECT ON 

THE 

INTERFACE ROWS 

90 

C 




100 


DO 20 K = NZ-1, 1, -1 



110 


DO 20 I = NRC , 1, -1 



120 


DO 10 J = 1, NRCPl 



130 


IPJ = I+J 



140 


L = ( IPJ-1 ) / NRC 



150 


IPJ = IPJ - L*NRC 



160 


KM = K + L 



170 

10 

DTNG ( I , K ) = DTNG ( I , K ) 

- 

TA ( NRCP2+ J , I , K ) * DTNG ( IPJ , KM ) 

180 


DO 30 J = 1, NR 



190 

30 

DTNG ( I , K ) = DTNG ( I , K ) 

- 

TF ( J , I , K ) * DFINTH ( J+l ) 

200 

20 

DTNG ( I , K ) = DTNG ( I , K ) 

/ 

TA ( NRCP2 , I , K ) 

210 

C 




n *•> r\ 
z. u 


DO 25 K = NZP2, NZC 



230 


DO 25 I = 1, NRC 



240 


DO 15 J = 1, NRCPl 



250 

15 

DTNG ( I , K ) = DTNG ( I , K ) 

- 

TA( NRCP2 - J , I , K ) * DTNG ( I - J , K ) 

260 


DO 35 J = 1, NR 



270 

35 

DTNG ( I , K ) = DTNG ( I , K ) 

- 

TF ( J , I , K ) * DFINTH ( J+l ) 

280 

25 

DTNG ( I , K ) = DTNG ( I , K ) 

/ 

TA( NRCP2 , I , K ) 

290 

C 




300 

C RESTORE DTNG TO DT 



310 

c 




320 


DO 95 K = 2, NZCP1 



330 


DO 95 I = 2, NRCPl 



340 

95 

DT ( I , K ) = DTNG ( I -1 , K - 

1) 


350 

C 




360 


RETURN 



6 5 33 B 


END 
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590 

C 

D 

.D. 

D 

• • * 

600 

C 

D 

.D. 

D 

• • • 

610 

C DTLA 

D 

.D. 

D 

• . . 

620 

C 

D 

.D. 

D 

. . . 

630 

640 

C 

C 

D 

• D 

D 

• • • 

650 

C 

D . 

D. 

D. 

• • 

660 

C 

.D. 

.D. 

. D • 

. . . 

670 

C 

• D . 

. D. 

.D. 

• • • 

680 

C DTC 

.D. 

.D. 

. D . 

• • • 

690 

C 

.D. 

. D. 

.D. 

• . . 

700 

710 

C 

C 

• D. 

.D. 

.D. 

• • • 

720 

C 

.D 

• D. 

.D 

. . • 

730 

C 

D 

.D. 

D 

. . . 

740 

c 

D 

.D. 

D 

• • » 

750 

C DTLA 

D 

• D. 

D 

• • ♦ 

760 

C 

D 

.D. 

D 

• • • 

770 

780 

C 

c 

D 

.D 

D 

• • * 

790 

c 

D. 

D. 



800 

c 

.D. 

.D. 


* . . 

810 

c 

.D. 

.D. 


. . . 

820 

C DTC 

.D. 

.D. 


. • . 

830 

C 

. D . 

.D. 


• . . 

840 

850 

C 

c 

.D. 

.D. 



860 

c 

. D 

• D. 



870 

c 

D 

.D. 



880 

c 

D 

.D. 


. . • 

890 

C DTLA 

D 

.D. 


. . . 

900 

C 

D 

.D. 



910 

920 

C 

C 

D 

.D 


• • * 


Pf&CE&iftQ ftAGs 




rags el&sc not mwa> 
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10 
20 
30 
40 
50 
60 
70 
80 
90 
100 
110 
120 
130 
140 
150 
160 
170 
180 
190 
200 
210 
220 
230 
240 
250 
260 
270 
280 
290 
300 
310 
320 
330 
340 
350 
360 
370 
380 
390 
400 
410 
420 
430 
440 
450 
460 
470 
480 
490 
500 
510 
520 
530 
540 
550 
560 
570 
rr n 


SUBROUTINE LEQ(NAIU) 

SOLVES SIMULTANEOUS LINEAR SYSTEM (SQUARE) NEAR INTERFACE 
SETS RESULTS IN RESULT ARRAYS 

INCLUDE ' COM. /NOLIST' 

DIMENSION WK ( NAI , 3 ) 


C 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


10 BI ( 2*NRC+NR+I ) - DCFINT ( 1+1 ) 

C 

C WRITE ARRAY DIAGNOSTIC BEFORE 
C 

IF (ISTEP .LE. 1 .AND. NAIU .LE. 67) THEN 

WRITE ( 6 , ' ( /' ' LEQ . RIGHT HAND SIDE'')') 

70 FORMAT ( /IX , A , (T10,1P,10E12.3) ) 

WRITE (6,70) ' DTU ' , ( BI ( I ) , 1=1 , NRC ) 

WRITE (6, 7 0 ) ' DTL ' , (BI(I+NRC) ,1 = 1, NRC) 

WRITE ( 6 , 70 ) ' DTFI ' , ( BI ( I+2*NRC ) , 1 = 1 ,NR) 

IF (LC) WRITE (6,70) ' DCFI ' , ( BI ( 1+2 *NRC+NR ) , 1=1 , NR ) 

IF (LC) WRITE (6,70) ' DCU' , ( BI ( 1+2 *NRC+NR* 2 ) , 1=1 , NR ) 


MATRIX ORDER: 
BASE ( xNR , xNRA ) : 
BASE ( xNR , xNRC ) : 

DTUS 

0,0 

0,0 

DTUA 

1,0 

1,0 

DTLS 

1,1 

0,1 

DTLA 

2,1 

1,1 

DF 

2,2 

0,2 

DT 

3.2 

1.2 

SET INTERFACE RHS 





DTFI 

DCFI 

THE REST OF THE RHS 

WAS SET 

EARLIER 

BY CNT2, 

AND POSSIBLY 

CNC2. 

DO 10 I = 1, 
BI(2*NRC+I) = 

NR 

DTFINT ( 

I + D 






ENDIF 


C 

C 

c 

c 

c 


SET UP MATRIX, IF REQUIRED. 

IF ( LLF ) THEN 

CALL LEQSET ( NAIU ) 
I JOB = 0 


I JOB = 1 


C 

C 

C 


ELSE 
ENDIF 
CALL SOLVER 

CALL LEQIF(AI , NAI , NAIU, NAIU, BI, NAI ,1,1 JOB, WK,IER) 


C 

C 

C 


IF ( IER .NE. 0) WRITE (6, 
IF (IER .NE. 0) WRITE (*, 

WRITE ARRAY DIAGNOSTIC AFTER 


IF (ISTEP .LE. 1 .AND 
IF ( I JOB .EQ. 0) 


(/' ' LEQ. IER =' ' , 14 ) 
(/' ' LEQ. IER =' ' , 14 ) 


67) THEN 


IER 

IER 


NAIU .LE. 

THEN 

CALL WAC(AI , NAI , NAIU, 1, 'AI AFTER% ' ) 
WRITE( 6 , ' ( /" LEQ. PIVOTS ' '/(1X,10F12 


on') 
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590 


1 

( WK ( 1,1), 1=1 ,NAIU) 

600 



WRITE ( 6 , ' ( / ' ' LEQ . PIVOTS' '/( 5X, IP, 10E12. 3) ) 

610 


1 

( WK ( 1,2), 1=1 ,NAIU) 

620 



ENDIF 

630 



WRITE ( 6 , ' ( / ' ' LEQ. SOLUTION'')') 

640 



WRITE (6, 70) ' DTU ' , { BI ( I ) , 1=1 , NRC ) 

650 



WRITE (6,70) ' DTL ' , (BI(I+NRC) ,1=1, NRC) 

660 



WRITE (6, 70) 'DF' , (BI(I+2*NRC) ,1=1, NR) 

670 



IF (LC) WRI TE (6,70) ' DTI NT ' , ( BI ( I+2*NRC+NR) , I 

680 



IF (LC) WRITE (6,70) ' DCU ' , ( BI ( I+2*NRC+NR*2 ) , I 

690 


END IF 


700 

C 



710 

C SET 

RESULT ARRAYS 

720 

C 



730 


DO 200 

1=1, NRC 

740 


DTNG ( I , 

NZ ) = BI ( I ) 

750 

200 

DTNG ( I , 

NZPl ) = BI ( I +NRC ) 

760 

C 



770 


DO 300 

I = 1, NR 

780 

300 

DFINTH ( 1+1 ) = BI(I+2*NRC) 

790 

C 



800 


IF ( LC ) 

THEN 

810 



DO 400 I = 1, NR 

820 



DTINTH ( 1 + 1 ) = B I ( 1 + 2 *NRC+NR ) 

830 

400 


DCNG ( I , NZ ) = BI ( I+2*NRC+2*NR) 

840 


ENDIF 


850 

C 



860 


RETURN 


6583B 


END 
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10 

20 

30 

40 

50 

60 

70 

80 

90 

100 

110 

120 

130 

140 

150 

160 

170 

180 

190 

200 

210 

220 

230 

240 

250 

260 

270 

280 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 

480 

490 

500 

510 

520 

530 

540 

550 

560 

570 

580 


SUBROUTINE LEQSET ( NAIU ) 

C 

C SETS UP INTERFACE FLUX ROWS OF INTERFACE MATRIX 
C 

C IF NOT (LC) THEN ROWS AND COLUMNS FOR DT AND DCU ARE SET BUT NOT USED, 
C UNDER CONTROL OF THE ARGUMENT NAIU PASSED TO LEQIF . 

C 


INCLUDE ' COM. /NOLIST' 


C 

c 


MATRIX ORDER: 
BASE ( xNR , xNRA ) : 
BASE ( xNR , xNRC ) : 

DTUS 

0,0 

0,0 

DTUA 

1,0 

1,0 

DTLS 

1,1 

0,1 

DTLA 

2,1 

1,1 

DF 

2,2 

0,2 

DT 

3.2 

1.2 

INTERFACE RHS 





DTFI 

DCFI 


DO 70 I = 1, NR 
C 

C SET THE TFI (DF) AND CFI ( DT ) EQUATION ROWS TO ZERO 
C 

IDF = I + 2 *NRC 
IDT = I + NRC* 2 + NR 
C 

DO 10 K = 1, NIA 
AI ( I DT , K ) = 0. 

10 AI ( IDF , K ) = 0. 

C 

C SET COLUMNS FOR TERMS WITH SAME I VALUE 
C 

IDC = I + 2 *NRC + 2 *NR 
IDU = I 
IDL = I + NRC 
C 

AI ( IDF , I DF ) = DFTINT ( 1+1 ) 

A I ( IDF ,’IDU ) = AI ( I DF , I DU ) + TZD ( 1 + 1 , NZPl ) * 2. 

AI ( IDF , IDL ) = AI ( I DF , IDL ) + TZICD(I+1) * 2. 

AI ( I DF , I DT ) = AI ( I DF , I DT ) - ( TZD ( 1+1 , NZPl ) + TZICD(I+1) ) * 2. 

AI ( IDT , IDF ) = DFCINT ( 1+1 ) 

AI ( IDT , IDC ) = AI ( I DT , IDC ) + CZD ( 1+1 , NZPl ) * 2. 

AI ( I DT , I DT ) = AI ( IDT, IDT ) - 2 * CZD ( 1+1 , NZPl ) * DCMDT(I+1) 

1 + DTCINT ( 1+1 ) 

C 

C 

C LEFT AND RIGHT FOR SLOPING MESH DIFFUSION TERMS 
C 

DO 20 IE = -1 , 1 , 2 
C 

C AXIS SYMMETRY AND ONE-SIDED DIFFERENCE AT RIGHT EDGE USED IN GETTING D 
C 

IF (I .EQ. NR) THEN 
RIE = 2 * I E 
I EE = MIN ( 0 , IE ) 

ELSE IF (I .EQ. 1 .AND. IE . EQ . -1) THEN 

I EE = 0 
RIE = IE 

ELSE C - O 

I EE = IE 
RIE = IE 
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590 



ENDIF 

600 

C 



610 



AI ( IDF , IDT+IEE ) = AI ( IDF , IDT+IEE ) 

620 



1 + ( TZE( 1+1 ,NZP1 ) - TZICE(I+1) ) * 2.*RIE 

630 

20 


AI ( IDT, IDT+IEE ) = AI ( I DT , I DT+ I EE ) 

640 



1 + CZE ( 1+1 , NZPl ) * 2 . *RI E * DCMDT ( I+l+IEE ) 

650 

C 



660 

C 

DO THE INTERFACE DF TERMS IN THE SAME I LOOP 

670 

C 


- 

680 



IF (I .EQ. NR) THEN 

690 



IWS = 1 

700 



ELSE 

710 



IWS = 0 

720 



ENDIF 

730 

C 



740 

C 

LOOP 

OVER TWO W POINTS (NORMALLY JUST THE NEIGHBORS) 

750 

C 



760 



DO 70 IW = IWS, MIN ( IWS+1 ,1*1) 

770 

c 



780 



WM = 0.5 + IWS - 2* ( IW- IWS) *IWS 

790 

c 



800 

c 

IWS 

= 0 GIVES ( IW , WM ) = (0,0.5) AND (1,0.5) 

810 

c 

IWS 

= 1 GIVES ( IW , WM ) = (1,1.5) AND (2, -0.5) 

820 

c 



830 

c 

NOW 

GO LEFT AND RIGHT TO H NEIGHBORS 

840 

c 



850 



DO 70 IE = -1, 0 

860 



I EM = IE+IE+1 

870 

c 



880 



AI ( IDT, IDF+1 - IW+IE ) = 

890 



1AI ( IDT , IDF + 1 - IW+IE ) + CZ F ( 1 + 1 , NZPl ) * IEM * WM * DIDRW(I+1- 

900 

70 

AI ( IDF, IDF+1 -IW+IE) = 

910 



1AI ( IDF , IDF+1 - IW+IE ) + (TZF(I+l,NZPl) - TZICF(I+1)) 

920 



1 * IEM * WM * DIDRW( 1 + 1 - IW) 

930 

C 



940 



IF (ISTEP .LE. 1 .AND. NAIU .LE. 67) THEN 

950 

c 


CALL WAC( AI ,NAI ,NAIU, 1 , 'AI BEFORE% ' ) 

960 



ENDIF 

970 

c 



980 



RETURN 

65996 



END 
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10 c 

20 C STRUCTURE OF AI MATRIX (NR = NRA = 6) 

30 C 
40 C 

50 C DTUS DTUA DTLS DTLA DF DT 

60 C 

70 C ...... ...... .. 

80 C ...... ...••• ...... ... 

90 C DTUS 

100 C • 

110 C 

120 C 

130 C 

140 C . 

1 50 C . 

160 C DTUA . 

170 C 

180 C 

190 C 

200 C 

2 j.0 C ...... ...... ...... .. 

220 C ...... ...... ...... ... 

230 C DTLS ...... •••••♦ •••••• ... 

^ ^ 0 l ...... ...... ...... .. 

250 C ...... ...... . 

260 C ...... ...... ...... 

270 C 

280 C • ...... •••••• ...... 

290 C • ...... ...... ...... 

300 C DTLA . 

310 C . ...... ...... 

320 C . ...... ...... ...••• 

330 C . ...... ...... ...... 

340 C 

350C . . •• • • 

360 C . • ... ... 

370 C TFI . . ...... 

380 C . • ... •< 

390 C . ... 

400 C .... 

410 C 

420 C .... 

430 C ...... 

440 C CFI 

450 C .... 

460 C 

470 C 

480 C 

490 C 

500 C ......... 

510 C DCU 

520 C 

530 C 

540 C 


DCU 
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10 


SUBROUTINE GVORT 

20 

C 


30 

C 


40 


INCLUDE 'COM. /NOLI ST 

50 

C 


60 

C 


70 


RETURN 

6558B 


END 
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10 


SUBROUTINE SETPSI 

20 

C 


30 

C SET 

STREAM FUNCTION USING ANALYTIC APPROXIMATE FORMULA ALLOWING FOR 

40 

C 


50 


INCLUDE 'COM. /NOLIST' 

60 

C 


70 


DO 10 K = 1, NZP1 

80 


IF (K .EQ. NZP1 ) THEN 

90 


P F = 1 . E 5 

100 


ELSE 

110 


PF = RSAM/( ZETW( K) - Z INT )/( PI *PI/4 -1 ) 

120 


ENDIF 

130 


PFPl = PF+1 

140 


PI = . 5* WAMP* ( ( 1 - DENCBM ) * ( 1 + 1/PFPl ) - 1) 

150 


P2 = . 5*WAMP* ( 1 -DENCBM) *( 1/PFPl ) 

160 


DO 10 I = 1, NRPl 

170 


PP = R2W(I) * ( PI - P2 * EXP ( LOG ( R2W ( I )/( RSAM*RSAM ) ) *PFP1 

180 


PSIO( I , K) = PP 

190 

10 

PSI ( I , K ) = PP 

200 

C 


210 


WRITE ( 6 ' SETPSI.'', 

220 


1 '' WAMP, DENCBM, RSAM , PF, Pi, P2 , PFPl, PP 

230 


1 /( 1P10E12 . 3 ) ) ' ) 

240 


1 WAMP, DENCBM, RSAM, PF, Pi, P2 , PFPl, PP 

250 

C 


260 


RETURN 

6523B 


END 
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SUBROUTINE PSIBC 

20 

C 


30 

C 

APPLY PSI BOUNDARY CONDITIONS, INCLUDING NO-SLIP. 

40 

C 


50 


INCLUDE ' COM. /NOLI ST' 

60 

C 


70 

C 

GET AWALL 

80 

C 


90 


IF ( LU ) THEN , ; 

100 


AWALL = 0 

110 


DO 3 I = 2, NRPl 

120 

3 

AWALL = AWALL + ( 1 - DENCBM ) * ( 4/RSAM/RSAM ) 

130 


1 * ( WAMP+DFINTH( I ) *BTF( I ) ) *RDRB2H(I)*2 

140 


ELSE 

150 


AWALL = (1 -DENCBM) * 2 * WAMP 

160 


ENDIF 

170 

C 


180 

C 

SYMMETRY AT THE LEFT AND RIGHT 

190 

c 


200 


DO 1 K = 1, NZP2 

210 


DPSI ( NRP2 , K ) = DPS I ( NR , K ) 

220 


PSI ( NRP2 , K ) = PS I ( NR , K ) - 2 * WAMP / DIDRW(NRPl) 

230 


DPSI ( NRPl , K ) = 0 

240 


PS I ( NRP 1 , K ) = (AWALL/ 4 - WAMP/2 ) * RSAM * RSAM 

250 


DPS I ( 1 , K ) = 0 

260 

1 

PSI ( 1 ,K) = 0 

270 

c 


280 

c 

IMPOSED AT THE TOP AND BOTTOM 

290 

c 


300 


DO 2 I = 2, NRPl 

310 


DPSI ( I , NZP 2 ) = DPS 1(1, NZP 1 ) 

320 


PSI ( I ,NZP2 ) = PS I ( I , NZ ) 

330 


DPSI (1,1) = DPSI ( 1,2) 

340 

2 

PS I (1,1) = (AWALL -WAMP) * 0.5 * R2W(I) 

350 


1 - AWALL * .25 / ( RSAM*RSAM ) * R4W( 

360 

C 


370 


RETURN 

380 


END 


I 


